2 % (c) The University of Glasgow 2006
12 #include "HsVersions.h"
14 import TcRnTypes -- Re-export all
15 import IOEnv -- Re-export all
17 import HsSyn hiding (LIE)
47 import qualified Data.Set as Set
53 %************************************************************************
57 %************************************************************************
63 -> Bool -- True <=> retain renamed syntax trees
66 -> IO (Messages, Maybe r)
67 -- Nothing => error thrown by the thing inside
68 -- (error messages should have been printed already)
70 initTc hsc_env hsc_src keep_rn_syntax mod do_this
71 = do { errs_var <- newIORef (emptyBag, emptyBag) ;
72 tvs_var <- newIORef emptyVarSet ;
73 dfuns_var <- newIORef emptyNameSet ;
74 keep_var <- newIORef emptyNameSet ;
75 used_rdrnames_var <- newIORef Set.empty ;
76 th_var <- newIORef False ;
77 dfun_n_var <- newIORef emptyOccSet ;
78 type_env_var <- case hsc_type_env_var hsc_env of {
79 Just (_mod, te_var) -> return te_var ;
80 Nothing -> newIORef emptyNameEnv } ;
82 maybe_rn_syntax empty_val
83 | keep_rn_syntax = Just empty_val
84 | otherwise = Nothing ;
89 tcg_rdr_env = hsc_global_rdr_env hsc_env,
90 tcg_fix_env = emptyNameEnv,
91 tcg_field_env = RecFields emptyNameEnv emptyNameSet,
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,
100 tcg_imports = emptyImportAvails,
101 tcg_used_rdrnames = used_rdrnames_var,
105 tcg_rn_exports = maybe_rn_syntax [],
106 tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
108 tcg_binds = emptyLHsBinds,
109 tcg_warns = NoWarnings,
115 tcg_dfun_n = dfun_n_var,
117 tcg_doc_hdr = Nothing,
123 tcl_loc = mkGeneralSrcSpan (fsLit "Top level"),
125 tcl_rdr = emptyLocalRdrEnv,
126 tcl_th_ctxt = topStage,
127 tcl_arrow_ctxt = NoArrowCtxt,
128 tcl_env = emptyNameEnv,
129 tcl_tyvars = tvs_var,
130 tcl_lie = panic "initTc:LIE", -- only valid inside getLIE
131 tcl_tybinds = panic "initTc:tybinds"
132 -- only valid inside a getTyBinds
136 -- OK, here's the business end!
137 maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
138 do { r <- tryM do_this
140 Right res -> return (Just res)
141 Left _ -> return Nothing } ;
143 -- Collect any error messages
144 msgs <- readIORef errs_var ;
146 let { dflags = hsc_dflags hsc_env
147 ; final_res | errorsFound dflags msgs = Nothing
148 | otherwise = maybe_res } ;
150 return (msgs, final_res)
153 initTcPrintErrors -- Used from the interactive loop only
157 -> IO (Messages, Maybe r)
158 initTcPrintErrors env mod todo = do
159 (msgs, res) <- initTc env HsSrcFile False mod todo
163 %************************************************************************
167 %************************************************************************
171 initTcRnIf :: Char -- Tag for unique supply
176 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
177 = do { us <- mkSplitUniqSupply uniq_tag ;
178 ; us_var <- newIORef us ;
180 ; let { env = Env { env_top = hsc_env,
185 ; runIOEnv env thing_inside
189 %************************************************************************
193 %************************************************************************
196 getTopEnv :: TcRnIf gbl lcl HscEnv
197 getTopEnv = do { env <- getEnv; return (env_top env) }
199 getGblEnv :: TcRnIf gbl lcl gbl
200 getGblEnv = do { env <- getEnv; return (env_gbl env) }
202 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
203 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
204 env { env_gbl = upd gbl })
206 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
207 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
209 getLclEnv :: TcRnIf gbl lcl lcl
210 getLclEnv = do { env <- getEnv; return (env_lcl env) }
212 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
213 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
214 env { env_lcl = upd lcl })
216 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
217 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
219 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
220 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
222 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
223 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
230 getDOpts :: TcRnIf gbl lcl DynFlags
231 getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
233 doptM :: DynFlag -> TcRnIf gbl lcl Bool
234 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
236 setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
237 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
238 env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
240 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
241 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
242 env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
244 -- | Do it flag is true
245 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
246 ifOptM flag thing_inside = do { b <- doptM flag;
247 if b then thing_inside else return () }
249 getGhcMode :: TcRnIf gbl lcl GhcMode
250 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
254 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
255 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
257 getEps :: TcRnIf gbl lcl ExternalPackageState
258 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
260 -- | Update the external package state. Returns the second result of the
261 -- modifier function.
263 -- This is an atomic operation and forces evaluation of the modified EPS in
264 -- order to avoid space leaks.
265 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
267 updateEps upd_fn = do
268 traceIf (text "updating EPS")
270 atomicUpdMutVar' eps_var upd_fn
272 -- | Update the external package state.
274 -- This is an atomic operation and forces evaluation of the modified EPS in
275 -- order to avoid space leaks.
276 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
278 updateEps_ upd_fn = do
279 traceIf (text "updating EPS_")
281 atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
283 getHpt :: TcRnIf gbl lcl HomePackageTable
284 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
286 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
287 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
288 ; return (eps, hsc_HPT env) }
291 %************************************************************************
295 %************************************************************************
298 newUnique :: TcRnIf gbl lcl Unique
300 = do { env <- getEnv ;
301 let { u_var = env_us env } ;
302 us <- readMutVar u_var ;
303 case splitUniqSupply us of { (us1,_) -> do {
304 writeMutVar u_var us1 ;
305 return $! uniqFromSupply us }}}
306 -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
307 -- a chain of unevaluated supplies behind.
308 -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
309 -- throw away one half of the new split supply. This is safe because this
310 -- is the only place we use that unique. Using the other half of the split
311 -- supply is safer, but slower.
313 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
315 = do { env <- getEnv ;
316 let { u_var = env_us env } ;
317 us <- readMutVar u_var ;
318 case splitUniqSupply us of { (us1,us2) -> do {
319 writeMutVar u_var us1 ;
322 newLocalName :: Name -> TcRnIf gbl lcl Name
323 newLocalName name -- Make a clone
324 = do { uniq <- newUnique
325 ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
327 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
328 newSysLocalIds fs tys
329 = do { us <- newUniqueSupply
330 ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
332 instance MonadUnique (IOEnv (Env gbl lcl)) where
333 getUniqueM = newUnique
334 getUniqueSupplyM = newUniqueSupply
338 %************************************************************************
342 %************************************************************************
345 traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
346 traceRn = traceOptTcRn Opt_D_dump_rn_trace
347 traceTc = traceOptTcRn Opt_D_dump_tc_trace
348 traceSplice = traceOptTcRn Opt_D_dump_splices
351 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
352 traceIf = traceOptIf Opt_D_dump_if_trace
353 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
356 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
357 traceOptIf flag doc = ifOptM flag $
358 liftIO (printForUser stderr alwaysQualify doc)
360 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
361 traceOptTcRn flag doc = ifOptM flag $ do
364 ; env0 <- tcInitTidyEnv
365 ; err_info <- mkErrInfo env0 ctxt
366 ; let real_doc = mkLocMessage loc (doc $$ err_info)
367 ; dumpTcRn real_doc }
369 dumpTcRn :: SDoc -> TcRn ()
370 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
372 ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
374 debugDumpTcRn :: SDoc -> TcRn ()
375 debugDumpTcRn doc | opt_NoDebugOutput = return ()
376 | otherwise = dumpTcRn doc
378 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
379 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
383 %************************************************************************
385 Typechecker global environment
387 %************************************************************************
390 getModule :: TcRn Module
391 getModule = do { env <- getGblEnv; return (tcg_mod env) }
393 setModule :: Module -> TcRn a -> TcRn a
394 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
396 tcIsHsBoot :: TcRn Bool
397 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
399 getGlobalRdrEnv :: TcRn GlobalRdrEnv
400 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
402 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
403 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
405 getImports :: TcRn ImportAvails
406 getImports = do { env <- getGblEnv; return (tcg_imports env) }
408 getFixityEnv :: TcRn FixityEnv
409 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
411 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
412 extendFixityEnv new_bit
413 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
414 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
416 getRecFieldEnv :: TcRn RecFieldEnv
417 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
419 getDeclaredDefaultTys :: TcRn (Maybe [Type])
420 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
423 %************************************************************************
427 %************************************************************************
430 getSrcSpanM :: TcRn SrcSpan
431 -- Avoid clash with Name.getSrcLoc
432 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
434 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
435 setSrcSpan loc thing_inside
436 | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
437 | otherwise = thing_inside -- Don't overwrite useful info with useless
439 addLocM :: (a -> TcM b) -> Located a -> TcM b
440 addLocM fn (L loc a) = setSrcSpan loc $ fn a
442 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
443 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
445 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
446 wrapLocFstM fn (L loc a) =
451 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
452 wrapLocSndM fn (L loc a) =
461 getErrsVar :: TcRn (TcRef Messages)
462 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
464 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
465 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
467 addErr :: Message -> TcRn () -- Ignores the context stack
468 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
470 failWith :: Message -> TcRn a
471 failWith msg = addErr msg >> failM
473 addErrAt :: SrcSpan -> Message -> TcRn ()
474 -- addErrAt is mainly (exclusively?) used by the renamer, where
475 -- tidying is not an issue, but it's all lazy so the extra
476 -- work doesn't matter
477 addErrAt loc msg = do { ctxt <- getErrCtxt
478 ; tidy_env <- tcInitTidyEnv
479 ; err_info <- mkErrInfo tidy_env ctxt
480 ; addLongErrAt loc msg err_info }
482 addErrs :: [(SrcSpan,Message)] -> TcRn ()
483 addErrs msgs = mapM_ add msgs
485 add (loc,msg) = addErrAt loc msg
487 addWarn :: Message -> TcRn ()
488 addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
490 addWarnAt :: SrcSpan -> Message -> TcRn ()
491 addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
493 checkErr :: Bool -> Message -> TcRn ()
494 -- Add the error if the bool is False
495 checkErr ok msg = unless ok (addErr msg)
497 warnIf :: Bool -> Message -> TcRn ()
498 warnIf True msg = addWarn msg
499 warnIf False _ = return ()
501 addMessages :: Messages -> TcRn ()
502 addMessages (m_warns, m_errs)
503 = do { errs_var <- getErrsVar ;
504 (warns, errs) <- readMutVar errs_var ;
505 writeMutVar errs_var (warns `unionBags` m_warns,
506 errs `unionBags` m_errs) }
508 discardWarnings :: TcRn a -> TcRn a
509 -- Ignore warnings inside the thing inside;
510 -- used to ignore-unused-variable warnings inside derived code
511 -- With -dppr-debug, the effects is switched off, so you can still see
512 -- what warnings derived code would give
513 discardWarnings thing_inside
514 | opt_PprStyle_Debug = thing_inside
516 = do { errs_var <- newMutVar emptyMessages
517 ; result <- setErrsVar errs_var thing_inside
518 ; (_warns, errs) <- readMutVar errs_var
519 ; addMessages (emptyBag, errs)
524 %************************************************************************
526 Shared error message stuff: renamer and typechecker
528 %************************************************************************
531 addReport :: Message -> Message -> TcRn ()
532 addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
534 addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
535 addReportAt loc msg extra_info
536 = do { errs_var <- getErrsVar ;
537 rdr_env <- getGlobalRdrEnv ;
539 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
541 (warns, errs) <- readMutVar errs_var ;
542 writeMutVar errs_var (warns `snocBag` warn, errs) }
544 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
545 addLongErrAt loc msg extra
546 = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
547 errs_var <- getErrsVar ;
548 rdr_env <- getGlobalRdrEnv ;
550 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
551 (warns, errs) <- readMutVar errs_var ;
552 writeMutVar errs_var (warns, errs `snocBag` err) }
557 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
558 -- Does try_m, with a debug-trace on failure
560 = do { mb_r <- tryM thing ;
562 Left exn -> do { traceTc (exn_msg exn); return mb_r }
563 Right _ -> return mb_r }
565 exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
567 -----------------------
568 recoverM :: TcRn r -- Recovery action; do this if the main one fails
569 -> TcRn r -- Main action: do this first
571 -- Errors in 'thing' are retained
572 recoverM recover thing
573 = do { mb_res <- try_m thing ;
576 Right res -> return res }
579 -----------------------
580 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
581 -- Drop elements of the input that fail, so the result
582 -- list can be shorter than the argument list
583 mapAndRecoverM _ [] = return []
584 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
585 ; rs <- mapAndRecoverM f xs
586 ; return (case mb_r of
591 -----------------------
592 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
593 -- (tryTc m) executes m, and returns
594 -- Just r, if m succeeds (returning r)
595 -- Nothing, if m fails
596 -- It also returns all the errors and warnings accumulated by m
597 -- It always succeeds (never raises an exception)
599 = do { errs_var <- newMutVar emptyMessages ;
600 res <- try_m (setErrsVar errs_var m) ;
601 msgs <- readMutVar errs_var ;
602 return (msgs, case res of
604 Right val -> Just val)
605 -- The exception is always the IOEnv built-in
606 -- in exception; see IOEnv.failM
609 -----------------------
610 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
611 -- Run the thing, returning
612 -- Just r, if m succceeds with no error messages
613 -- Nothing, if m fails, or if it succeeds but has error messages
614 -- Either way, the messages are returned; even in the Just case
615 -- there might be warnings
617 = do { (msgs, res) <- tryTc thing
619 ; let errs_found = errorsFound dflags msgs
620 ; return (msgs, case res of
622 Just val | errs_found -> Nothing
623 | otherwise -> Just val)
626 -----------------------
627 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
628 -- Just like tryTcErrs, except that it ensures that the LIE
629 -- for the thing is propagated only if there are no errors
630 -- Hence it's restricted to the type-check monad
631 tryTcLIE thing_inside
632 = do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
634 Nothing -> return (msgs, Nothing)
635 Just val -> do { extendLIEs lie; return (msgs, Just val) }
638 -----------------------
639 tryTcLIE_ :: TcM r -> TcM r -> TcM r
640 -- (tryTcLIE_ r m) tries m;
641 -- if m succeeds with no error messages, it's the answer
642 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
643 tryTcLIE_ recover main
644 = do { (msgs, mb_res) <- tryTcLIE main
646 Just val -> do { addMessages msgs -- There might be warnings
648 Nothing -> recover -- Discard all msgs
651 -----------------------
652 checkNoErrs :: TcM r -> TcM r
653 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
654 -- If m fails then (checkNoErrsTc m) fails.
655 -- If m succeeds, it checks whether m generated any errors messages
656 -- (it might have recovered internally)
657 -- If so, it fails too.
658 -- Regardless, any errors generated by m are propagated to the enclosing context.
660 = do { (msgs, mb_res) <- tryTcLIE main
664 Just val -> return val
667 ifErrsM :: TcRn r -> TcRn r -> TcRn r
668 -- ifErrsM bale_out main
669 -- does 'bale_out' if there are errors in errors collection
670 -- otherwise does 'main'
671 ifErrsM bale_out normal
672 = do { errs_var <- getErrsVar ;
673 msgs <- readMutVar errs_var ;
675 if errorsFound dflags msgs then
680 failIfErrsM :: TcRn ()
681 -- Useful to avoid error cascades
682 failIfErrsM = ifErrsM failM (return ())
686 %************************************************************************
688 Context management for the type checker
690 %************************************************************************
693 getErrCtxt :: TcM [ErrCtxt]
694 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
696 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
697 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
699 addErrCtxt :: Message -> TcM a -> TcM a
700 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
702 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
703 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
705 addLandmarkErrCtxt :: Message -> TcM a -> TcM a
706 addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
708 -- Helper function for the above
709 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
710 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
711 env { tcl_ctxt = upd ctxt })
713 -- Conditionally add an error context
714 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
715 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
716 maybeAddErrCtxt Nothing thing_inside = thing_inside
718 popErrCtxt :: TcM a -> TcM a
719 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
721 getInstLoc :: InstOrigin -> TcM InstLoc
723 = do { loc <- getSrcSpanM ; env <- getLclEnv ;
724 return (InstLoc origin loc (tcl_ctxt env)) }
726 setInstCtxt :: InstLoc -> TcM a -> TcM a
727 -- Add the SrcSpan and context from the first Inst in the list
728 -- (they all have similar locations)
729 setInstCtxt (InstLoc _ src_loc ctxt) thing_inside
730 = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
733 %************************************************************************
735 Error message generation (type checker)
737 %************************************************************************
739 The addErrTc functions add an error message, but do not cause failure.
740 The 'M' variants pass a TidyEnv that has already been used to
741 tidy up the message; we then use it to tidy the context messages
744 addErrTc :: Message -> TcM ()
745 addErrTc err_msg = do { env0 <- tcInitTidyEnv
746 ; addErrTcM (env0, err_msg) }
748 addErrsTc :: [Message] -> TcM ()
749 addErrsTc err_msgs = mapM_ addErrTc err_msgs
751 addErrTcM :: (TidyEnv, Message) -> TcM ()
752 addErrTcM (tidy_env, err_msg)
753 = do { ctxt <- getErrCtxt ;
755 add_err_tcm tidy_env err_msg loc ctxt }
758 The failWith functions add an error message and cause failure
761 failWithTc :: Message -> TcM a -- Add an error message and fail
763 = addErrTc err_msg >> failM
765 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
766 failWithTcM local_and_msg
767 = addErrTcM local_and_msg >> failM
769 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
770 checkTc True _ = return ()
771 checkTc False err = failWithTc err
774 Warnings have no 'M' variant, nor failure
777 addWarnTc :: Message -> TcM ()
778 addWarnTc msg = do { env0 <- tcInitTidyEnv
779 ; addWarnTcM (env0, msg) }
781 addWarnTcM :: (TidyEnv, Message) -> TcM ()
782 addWarnTcM (env0, msg)
783 = do { ctxt <- getErrCtxt ;
784 err_info <- mkErrInfo env0 ctxt ;
785 addReport (ptext (sLit "Warning:") <+> msg) err_info }
787 warnTc :: Bool -> Message -> TcM ()
788 warnTc warn_if_true warn_msg
789 | warn_if_true = addWarnTc warn_msg
790 | otherwise = return ()
793 -----------------------------------
796 We initialise the "tidy-env", used for tidying types before printing,
797 by building a reverse map from the in-scope type variables to the
798 OccName that the programmer originally used for them
801 tcInitTidyEnv :: TcM TidyEnv
803 = do { lcl_env <- getLclEnv
804 ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
805 | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
807 ; return (foldl add emptyTidyEnv nm_tv_prs) }
809 add (env,subst) (name, tyvar)
810 = case tidyOccName env (nameOccName name) of
811 (env', occ') -> (env', extendVarEnv subst tyvar tyvar')
813 tyvar' = setTyVarName tyvar name'
814 name' = tidyNameOcc name occ'
817 -----------------------------------
818 Other helper functions
821 add_err_tcm :: TidyEnv -> Message -> SrcSpan
824 add_err_tcm tidy_env err_msg loc ctxt
825 = do { err_info <- mkErrInfo tidy_env ctxt ;
826 addLongErrAt loc err_msg err_info }
828 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
829 -- Tidy the error info, trimming excessive contexts
833 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
834 go _ _ [] = return empty
835 go n env ((is_landmark, ctxt) : ctxts)
836 | is_landmark || opt_PprStyle_Debug || n < mAX_CONTEXTS
837 = do { (env', msg) <- ctxt env
838 ; let n' = if is_landmark then n else n+1
839 ; rest <- go n' env' ctxts
840 ; return (msg $$ rest) }
844 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
848 debugTc is useful for monadic debugging code
851 debugTc :: TcM () -> TcM ()
854 | otherwise = return ()
857 %************************************************************************
859 Type constraints (the so-called LIE)
861 %************************************************************************
864 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
865 chooseUniqueOccTc fn =
866 do { env <- getGblEnv
867 ; let dfun_n_var = tcg_dfun_n env
868 ; set <- readMutVar dfun_n_var
870 ; writeMutVar dfun_n_var (extendOccSet set occ)
874 getLIEVar :: TcM (TcRef LIE)
875 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
877 setLIEVar :: TcRef LIE -> TcM a -> TcM a
878 setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
880 getLIE :: TcM a -> TcM (a, [Inst])
881 -- (getLIE m) runs m, and returns the type constraints it generates
883 = do { lie_var <- newMutVar emptyLIE ;
884 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
886 lie <- readMutVar lie_var ;
887 return (res, lieToList lie) }
889 extendLIE :: Inst -> TcM ()
891 = do { lie_var <- getLIEVar ;
892 lie <- readMutVar lie_var ;
893 writeMutVar lie_var (inst `consLIE` lie) }
895 extendLIEs :: [Inst] -> TcM ()
899 = do { lie_var <- getLIEVar ;
900 lie <- readMutVar lie_var ;
901 writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
905 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
906 -- Set the local type envt, but do *not* disturb other fields,
907 -- notably the lie_var
908 setLclTypeEnv lcl_env thing_inside
909 = updLclEnv upd thing_inside
911 upd env = env { tcl_env = tcl_env lcl_env,
912 tcl_tyvars = tcl_tyvars lcl_env }
916 %************************************************************************
918 Meta type variable bindings
920 %************************************************************************
923 getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds)
924 getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) }
926 getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds)
927 getTcTyVarBinds thing_inside
928 = do { tybinds_var <- newMutVar emptyBag
929 ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var })
931 ; tybinds <- readMutVar tybinds_var
932 ; return (res, tybinds)
935 bindMetaTyVar :: TcTyVar -> TcType -> TcM ()
937 = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv)
938 ; return (isFlexi details) }, ppr tv )
939 ; tybinds_var <- getTcTyVarBindsVar
940 ; tybinds <- readMutVar tybinds_var
941 ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty)
944 getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)]
945 getTcTyVarBindsRelation
946 = do { tybinds_var <- getTcTyVarBindsVar
947 ; tybinds <- readMutVar tybinds_var
948 ; return $ map freeTvs (bagToList tybinds)
951 freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty)
954 %************************************************************************
956 Template Haskell context
958 %************************************************************************
961 recordThUse :: TcM ()
962 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
964 keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set
966 | isLocalId id = do { env <- getGblEnv;
967 ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
968 | otherwise = return ()
970 keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set
971 keepAliveSetTc ns = do { env <- getGblEnv;
972 ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
974 getStage :: TcM ThStage
975 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
977 setStage :: ThStage -> TcM a -> TcM a
978 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
982 %************************************************************************
984 Stuff for the renamer's local env
986 %************************************************************************
989 getLocalRdrEnv :: RnM LocalRdrEnv
990 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
992 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
993 setLocalRdrEnv rdr_env thing_inside
994 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
998 %************************************************************************
1000 Stuff for interface decls
1002 %************************************************************************
1005 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1006 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
1008 if_tv_env = emptyUFM,
1009 if_id_env = emptyUFM }
1011 initIfaceTcRn :: IfG a -> TcRn a
1012 initIfaceTcRn thing_inside
1013 = do { tcg_env <- getGblEnv
1014 ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
1015 ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
1016 ; setEnvs (if_env, ()) thing_inside }
1018 initIfaceExtCore :: IfL a -> TcRn a
1019 initIfaceExtCore thing_inside
1020 = do { tcg_env <- getGblEnv
1021 ; let { mod = tcg_mod tcg_env
1022 ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
1023 ; if_env = IfGblEnv {
1024 if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
1025 ; if_lenv = mkIfLclEnv mod doc
1027 ; setEnvs (if_env, if_lenv) thing_inside }
1029 initIfaceCheck :: HscEnv -> IfG a -> IO a
1030 -- Used when checking the up-to-date-ness of the old Iface
1031 -- Initialise the environment with no useful info at all
1032 initIfaceCheck hsc_env do_this
1033 = do let rec_types = case hsc_type_env_var hsc_env of
1034 Just (mod,var) -> Just (mod, readMutVar var)
1036 gbl_env = IfGblEnv { if_rec_types = rec_types }
1037 initTcRnIf 'i' hsc_env gbl_env () do_this
1039 initIfaceTc :: ModIface
1040 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1041 -- Used when type-checking checking an up-to-date interface file
1042 -- No type envt from the current module, but we do know the module dependencies
1043 initIfaceTc iface do_this
1044 = do { tc_env_var <- newMutVar emptyTypeEnv
1045 ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
1046 ; if_lenv = mkIfLclEnv mod doc
1048 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1051 mod = mi_module iface
1052 doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1054 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
1055 -- Used when sucking in new Rules in SimplCore
1056 -- We have available the type envt of the module being compiled, and we must use it
1057 initIfaceRules hsc_env guts do_this
1059 type_info = (mg_module guts, return (mg_types guts))
1060 ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
1063 -- Run the thing; any exceptions just bubble out from here
1064 ; initTcRnIf 'i' hsc_env gbl_env () do_this
1067 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1068 initIfaceLcl mod loc_doc thing_inside
1069 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1071 getIfModule :: IfL Module
1072 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1074 --------------------
1075 failIfM :: Message -> IfL a
1076 -- The Iface monad doesn't have a place to accumulate errors, so we
1077 -- just fall over fast if one happens; it "shouldnt happen".
1078 -- We use IfL here so that we can get context info out of the local env
1080 = do { env <- getLclEnv
1081 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1082 ; liftIO (printErrs (full_msg defaultErrStyle))
1085 --------------------
1086 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1087 -- Run thing_inside in an interleaved thread.
1088 -- It shares everything with the parent thread, so this is DANGEROUS.
1090 -- It returns Nothing if the computation fails
1092 -- It's used for lazily type-checking interface
1093 -- signatures, which is pretty benign
1095 forkM_maybe doc thing_inside
1096 = do { unsafeInterleaveM $
1097 do { traceIf (text "Starting fork {" <+> doc)
1099 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1102 Right r -> do { traceIf (text "} ending fork" <+> doc)
1106 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1107 -- Otherwise we silently discard errors. Errors can legitimately
1108 -- happen when compiling interface signatures (see tcInterfaceSigs)
1109 ifOptM Opt_D_dump_if_trace
1110 (print_errs (hang (text "forkM failed:" <+> doc)
1111 4 (text (show exn))))
1113 ; traceIf (text "} ending fork (badly)" <+> doc)
1117 print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1119 forkM :: SDoc -> IfL a -> IfL a
1120 forkM doc thing_inside
1121 = do { mb_res <- forkM_maybe doc thing_inside
1122 ; return (case mb_res of
1123 Nothing -> pgmError "Cannot continue after interface file error"
1124 -- pprPanic "forkM" doc