2 % (c) The University of Glasgow 2006
12 #include "HsVersions.h"
14 import TcRnTypes -- Re-export all
15 import IOEnv -- Re-export all
17 #if defined(GHCI) && defined(BREAKPOINT)
29 import HsSyn hiding (LIE)
58 import Control.Exception
63 %************************************************************************
67 %************************************************************************
70 ioToTcRn :: IO r -> TcRn r
79 -> IO (Messages, Maybe r)
80 -- Nothing => error thrown by the thing inside
81 -- (error messages should have been printed already)
83 initTc hsc_env hsc_src mod do_this
84 = do { errs_var <- newIORef (emptyBag, emptyBag) ;
85 tvs_var <- newIORef emptyVarSet ;
86 type_env_var <- newIORef emptyNameEnv ;
87 dfuns_var <- newIORef emptyNameSet ;
88 keep_var <- newIORef emptyNameSet ;
89 th_var <- newIORef False ;
90 dfun_n_var <- newIORef 1 ;
95 tcg_rdr_env = hsc_global_rdr_env hsc_env,
96 tcg_fix_env = emptyNameEnv,
97 tcg_default = Nothing,
98 tcg_type_env = hsc_global_type_env hsc_env,
99 tcg_type_env_var = type_env_var,
100 tcg_inst_env = emptyInstEnv,
101 tcg_fam_inst_env = emptyFamInstEnv,
102 tcg_inst_uses = dfuns_var,
103 tcg_th_used = th_var,
105 tcg_imports = emptyImportAvails,
107 tcg_rn_imports = Nothing,
108 tcg_rn_exports = Nothing,
109 tcg_rn_decls = Nothing,
110 tcg_binds = emptyLHsBinds,
111 tcg_deprecs = NoDeprecs,
116 tcg_dfun_n = dfun_n_var,
119 tcg_hmi = HaddockModInfo Nothing Nothing Nothing 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" -- LIE only valid inside a getLIE
134 -- OK, here's the business end!
135 maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
136 addBreakpointBindings $
137 do { r <- tryM do_this
139 Right res -> return (Just res)
140 Left _ -> return Nothing } ;
142 -- Collect any error messages
143 msgs <- readIORef errs_var ;
145 let { dflags = hsc_dflags hsc_env
146 ; final_res | errorsFound dflags msgs = Nothing
147 | otherwise = maybe_res } ;
149 return (msgs, final_res)
152 initTcPrintErrors -- Used from the interactive loop only
157 initTcPrintErrors env mod todo = do
158 (msgs, res) <- initTc env HsSrcFile mod todo
159 printErrorsAndWarnings (hsc_dflags env) msgs
164 addBreakpointBindings :: TcM a -> TcM a
165 addBreakpointBindings thing_inside
166 #if defined(GHCI) && defined(BREAKPOINT)
167 = do { unique <- newUnique
168 ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
169 tyvar = mkTyVar var liftedTypeKind;
170 basicType extra = (FunTy intTy
171 (FunTy (mkListTy unitTy)
175 (FunTy (TyVarTy tyvar)
176 (TyVarTy tyvar)))))));
178 = mkGlobalId VanillaGlobal breakpointJumpName
179 (basicType id) vanillaIdInfo;
181 = mkGlobalId VanillaGlobal breakpointCondJumpName
182 (basicType (FunTy boolTy)) vanillaIdInfo
184 ; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside}
190 %************************************************************************
194 %************************************************************************
198 initTcRnIf :: Char -- Tag for unique supply
203 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
204 = do { us <- mkSplitUniqSupply uniq_tag ;
205 ; us_var <- newIORef us ;
207 ; let { env = Env { env_top = hsc_env,
210 env_lcl = lcl_env } }
212 ; runIOEnv env thing_inside
216 %************************************************************************
220 %************************************************************************
223 getTopEnv :: TcRnIf gbl lcl HscEnv
224 getTopEnv = do { env <- getEnv; return (env_top env) }
226 getGblEnv :: TcRnIf gbl lcl gbl
227 getGblEnv = do { env <- getEnv; return (env_gbl env) }
229 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
230 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
231 env { env_gbl = upd gbl })
233 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
234 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
236 getLclEnv :: TcRnIf gbl lcl lcl
237 getLclEnv = do { env <- getEnv; return (env_lcl env) }
239 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
240 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
241 env { env_lcl = upd lcl })
243 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
244 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
246 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
247 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
249 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
250 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
257 getDOpts :: TcRnIf gbl lcl DynFlags
258 getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
260 doptM :: DynFlag -> TcRnIf gbl lcl Bool
261 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
263 setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
264 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
265 env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
267 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
268 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
269 env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
271 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true
272 ifOptM flag thing_inside = do { b <- doptM flag;
273 if b then thing_inside else return () }
275 getGhcMode :: TcRnIf gbl lcl GhcMode
276 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
280 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
281 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
283 getEps :: TcRnIf gbl lcl ExternalPackageState
284 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
286 -- Updating the EPS. This should be an atomic operation.
287 -- Note the delicate 'seq' which forces the EPS before putting it in the
288 -- variable. Otherwise what happens is that we get
289 -- write eps_var (....(unsafeRead eps_var)....)
290 -- and if the .... is strict, that's obviously bottom. By forcing it beforehand
291 -- we make the unsafeRead happen before we update the variable.
293 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
295 updateEps upd_fn = do { traceIf (text "updating EPS")
296 ; eps_var <- getEpsVar
297 ; eps <- readMutVar eps_var
298 ; let { (eps', val) = upd_fn eps }
299 ; seq eps' (writeMutVar eps_var eps')
302 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
304 updateEps_ upd_fn = do { traceIf (text "updating EPS_")
305 ; eps_var <- getEpsVar
306 ; eps <- readMutVar eps_var
307 ; let { eps' = upd_fn eps }
308 ; seq eps' (writeMutVar eps_var eps') }
310 getHpt :: TcRnIf gbl lcl HomePackageTable
311 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
313 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
314 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
315 ; return (eps, hsc_HPT env) }
318 %************************************************************************
322 %************************************************************************
325 newUnique :: TcRnIf gbl lcl Unique
327 = do { env <- getEnv ;
328 let { u_var = env_us env } ;
329 us <- readMutVar u_var ;
330 case splitUniqSupply us of { (us1,_) -> do {
331 writeMutVar u_var us1 ;
332 return $! uniqFromSupply us }}}
333 -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
334 -- a chain of unevaluated supplies behind.
335 -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
336 -- throw away one half of the new split supply. This is safe because this
337 -- is the only place we use that unique. Using the other half of the split
338 -- supply is safer, but slower.
340 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
342 = do { env <- getEnv ;
343 let { u_var = env_us env } ;
344 us <- readMutVar u_var ;
345 case splitUniqSupply us of { (us1,us2) -> do {
346 writeMutVar u_var us1 ;
349 newLocalName :: Name -> TcRnIf gbl lcl Name
350 newLocalName name -- Make a clone
351 = do { uniq <- newUnique
352 ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) }
354 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
355 newSysLocalIds fs tys
356 = do { us <- newUniqueSupply
357 ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
361 %************************************************************************
365 %************************************************************************
368 traceTc, traceRn :: SDoc -> TcRn ()
369 traceRn = traceOptTcRn Opt_D_dump_rn_trace
370 traceTc = traceOptTcRn Opt_D_dump_tc_trace
371 traceSplice = traceOptTcRn Opt_D_dump_splices
374 traceIf :: SDoc -> TcRnIf m n ()
375 traceIf = traceOptIf Opt_D_dump_if_trace
376 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
379 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
380 traceOptIf flag doc = ifOptM flag $
381 ioToIOEnv (printForUser stderr alwaysQualify doc)
383 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
384 traceOptTcRn flag doc = ifOptM flag $ do
387 ; env0 <- tcInitTidyEnv
388 ; ctxt_msgs <- do_ctxt env0 ctxt
389 ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
390 ; dumpTcRn real_doc }
392 dumpTcRn :: SDoc -> TcRn ()
393 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
394 ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
396 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
397 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
401 %************************************************************************
403 Typechecker global environment
405 %************************************************************************
408 getModule :: TcRn Module
409 getModule = do { env <- getGblEnv; return (tcg_mod env) }
411 setModule :: Module -> TcRn a -> TcRn a
412 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
414 tcIsHsBoot :: TcRn Bool
415 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
417 getGlobalRdrEnv :: TcRn GlobalRdrEnv
418 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
420 getImports :: TcRn ImportAvails
421 getImports = do { env <- getGblEnv; return (tcg_imports env) }
423 getFixityEnv :: TcRn FixityEnv
424 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
426 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
427 extendFixityEnv new_bit
428 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
429 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
431 getDefaultTys :: TcRn (Maybe [Type])
432 getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
435 %************************************************************************
439 %************************************************************************
442 getSrcSpanM :: TcRn SrcSpan
443 -- Avoid clash with Name.getSrcLoc
444 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
446 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
447 setSrcSpan loc thing_inside
448 | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
449 | otherwise = thing_inside -- Don't overwrite useful info with useless
451 addLocM :: (a -> TcM b) -> Located a -> TcM b
452 addLocM fn (L loc a) = setSrcSpan loc $ fn a
454 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
455 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
457 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
458 wrapLocFstM fn (L loc a) =
463 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
464 wrapLocSndM fn (L loc a) =
472 getErrsVar :: TcRn (TcRef Messages)
473 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
475 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
476 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
478 addErr :: Message -> TcRn ()
479 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
481 addLocErr :: Located e -> (e -> Message) -> TcRn ()
482 addLocErr (L loc e) fn = addErrAt loc (fn e)
484 addErrAt :: SrcSpan -> Message -> TcRn ()
485 addErrAt loc msg = addLongErrAt loc msg empty
487 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
488 addLongErrAt loc msg extra
489 = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
490 errs_var <- getErrsVar ;
491 rdr_env <- getGlobalRdrEnv ;
492 let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
493 (warns, errs) <- readMutVar errs_var ;
494 writeMutVar errs_var (warns, errs `snocBag` err) }
496 addErrs :: [(SrcSpan,Message)] -> TcRn ()
497 addErrs msgs = mappM_ add msgs
499 add (loc,msg) = addErrAt loc msg
501 addReport :: Message -> TcRn ()
502 addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
504 addReportAt :: SrcSpan -> Message -> TcRn ()
506 = do { errs_var <- getErrsVar ;
507 rdr_env <- getGlobalRdrEnv ;
508 let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
509 (warns, errs) <- readMutVar errs_var ;
510 writeMutVar errs_var (warns `snocBag` warn, errs) }
512 addWarn :: Message -> TcRn ()
513 addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
515 addWarnAt :: SrcSpan -> Message -> TcRn ()
516 addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg)
518 addLocWarn :: Located e -> (e -> Message) -> TcRn ()
519 addLocWarn (L loc e) fn = addReportAt loc (fn e)
521 checkErr :: Bool -> Message -> TcRn ()
522 -- Add the error if the bool is False
523 checkErr ok msg = checkM ok (addErr msg)
525 warnIf :: Bool -> Message -> TcRn ()
526 warnIf True msg = addWarn msg
527 warnIf False msg = return ()
529 addMessages :: Messages -> TcRn ()
530 addMessages (m_warns, m_errs)
531 = do { errs_var <- getErrsVar ;
532 (warns, errs) <- readMutVar errs_var ;
533 writeMutVar errs_var (warns `unionBags` m_warns,
534 errs `unionBags` m_errs) }
536 discardWarnings :: TcRn a -> TcRn a
537 -- Ignore warnings inside the thing inside;
538 -- used to ignore-unused-variable warnings inside derived code
539 -- With -dppr-debug, the effects is switched off, so you can still see
540 -- what warnings derived code would give
541 discardWarnings thing_inside
542 | opt_PprStyle_Debug = thing_inside
544 = do { errs_var <- newMutVar emptyMessages
545 ; result <- setErrsVar errs_var thing_inside
546 ; (_warns, errs) <- readMutVar errs_var
547 ; addMessages (emptyBag, errs)
553 try_m :: TcRn r -> TcRn (Either Exception r)
554 -- Does try_m, with a debug-trace on failure
556 = do { mb_r <- tryM thing ;
558 Left exn -> do { traceTc (exn_msg exn); return mb_r }
559 Right r -> return mb_r }
561 exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
563 -----------------------
564 recoverM :: TcRn r -- Recovery action; do this if the main one fails
565 -> TcRn r -- Main action: do this first
567 -- Errors in 'thing' are retained
568 recoverM recover thing
569 = do { mb_res <- try_m thing ;
572 Right res -> returnM res }
574 -----------------------
575 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
576 -- (tryTc m) executes m, and returns
577 -- Just r, if m succeeds (returning r)
578 -- Nothing, if m fails
579 -- It also returns all the errors and warnings accumulated by m
580 -- It always succeeds (never raises an exception)
582 = do { errs_var <- newMutVar emptyMessages ;
583 res <- try_m (setErrsVar errs_var m) ;
584 msgs <- readMutVar errs_var ;
585 return (msgs, case res of
587 Right val -> Just val)
588 -- The exception is always the IOEnv built-in
589 -- in exception; see IOEnv.failM
592 -----------------------
593 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
594 -- Run the thing, returning
595 -- Just r, if m succceeds with no error messages
596 -- Nothing, if m fails, or if it succeeds but has error messages
597 -- Either way, the messages are returned; even in the Just case
598 -- there might be warnings
600 = do { (msgs, res) <- tryTc thing
602 ; let errs_found = errorsFound dflags msgs
603 ; return (msgs, case res of
605 Just val | errs_found -> Nothing
606 | otherwise -> Just val)
609 -----------------------
610 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
611 -- Just like tryTcErrs, except that it ensures that the LIE
612 -- for the thing is propagated only if there are no errors
613 -- Hence it's restricted to the type-check monad
614 tryTcLIE thing_inside
615 = do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
617 Nothing -> return (msgs, Nothing)
618 Just val -> do { extendLIEs lie; return (msgs, Just val) }
621 -----------------------
622 tryTcLIE_ :: TcM r -> TcM r -> TcM r
623 -- (tryTcLIE_ r m) tries m;
624 -- if m succeeds with no error messages, it's the answer
625 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
626 tryTcLIE_ recover main
627 = do { (msgs, mb_res) <- tryTcLIE main
629 Just val -> do { addMessages msgs -- There might be warnings
631 Nothing -> recover -- Discard all msgs
634 -----------------------
635 checkNoErrs :: TcM r -> TcM r
636 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
637 -- If m fails then (checkNoErrsTc m) fails.
638 -- If m succeeds, it checks whether m generated any errors messages
639 -- (it might have recovered internally)
640 -- If so, it fails too.
641 -- Regardless, any errors generated by m are propagated to the enclosing context.
643 = do { (msgs, mb_res) <- tryTcLIE main
647 Just val -> return val
650 ifErrsM :: TcRn r -> TcRn r -> TcRn r
651 -- ifErrsM bale_out main
652 -- does 'bale_out' if there are errors in errors collection
653 -- otherwise does 'main'
654 ifErrsM bale_out normal
655 = do { errs_var <- getErrsVar ;
656 msgs <- readMutVar errs_var ;
658 if errorsFound dflags msgs then
663 failIfErrsM :: TcRn ()
664 -- Useful to avoid error cascades
665 failIfErrsM = ifErrsM failM (return ())
669 %************************************************************************
671 Context management and error message generation
674 %************************************************************************
677 getErrCtxt :: TcM ErrCtxt
678 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
680 setErrCtxt :: ErrCtxt -> TcM a -> TcM a
681 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
683 addErrCtxt :: Message -> TcM a -> TcM a
684 addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
686 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
687 addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
689 -- Helper function for the above
690 updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
691 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
692 env { tcl_ctxt = upd ctxt })
694 -- Conditionally add an error context
695 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
696 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
697 maybeAddErrCtxt Nothing thing_inside = thing_inside
699 popErrCtxt :: TcM a -> TcM a
700 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
702 getInstLoc :: InstOrigin -> TcM InstLoc
704 = do { loc <- getSrcSpanM ; env <- getLclEnv ;
705 return (InstLoc origin loc (tcl_ctxt env)) }
707 addInstCtxt :: InstLoc -> TcM a -> TcM a
708 -- Add the SrcSpan and context from the first Inst in the list
709 -- (they all have similar locations)
710 addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
711 = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
714 The addErrTc functions add an error message, but do not cause failure.
715 The 'M' variants pass a TidyEnv that has already been used to
716 tidy up the message; we then use it to tidy the context messages
719 addErrTc :: Message -> TcM ()
720 addErrTc err_msg = do { env0 <- tcInitTidyEnv
721 ; addErrTcM (env0, err_msg) }
723 addErrsTc :: [Message] -> TcM ()
724 addErrsTc err_msgs = mappM_ addErrTc err_msgs
726 addErrTcM :: (TidyEnv, Message) -> TcM ()
727 addErrTcM (tidy_env, err_msg)
728 = do { ctxt <- getErrCtxt ;
730 add_err_tcm tidy_env err_msg loc ctxt }
733 The failWith functions add an error message and cause failure
736 failWithTc :: Message -> TcM a -- Add an error message and fail
738 = addErrTc err_msg >> failM
740 failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
741 failWithTcM local_and_msg
742 = addErrTcM local_and_msg >> failM
744 checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
745 checkTc True err = returnM ()
746 checkTc False err = failWithTc err
749 Warnings have no 'M' variant, nor failure
752 addWarnTc :: Message -> TcM ()
754 = do { ctxt <- getErrCtxt ;
755 env0 <- tcInitTidyEnv ;
756 ctxt_msgs <- do_ctxt env0 ctxt ;
757 addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
759 warnTc :: Bool -> Message -> TcM ()
760 warnTc warn_if_true warn_msg
761 | warn_if_true = addWarnTc warn_msg
762 | otherwise = return ()
765 -----------------------------------
768 We initialise the "tidy-env", used for tidying types before printing,
769 by building a reverse map from the in-scope type variables to the
770 OccName that the programmer originally used for them
773 tcInitTidyEnv :: TcM TidyEnv
775 = do { lcl_env <- getLclEnv
776 ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
777 | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
779 ; return (foldl add emptyTidyEnv nm_tv_prs) }
781 add (env,subst) (name, tyvar)
782 = case tidyOccName env (nameOccName name) of
783 (env', occ') -> (env', extendVarEnv subst tyvar tyvar')
785 tyvar' = setTyVarName tyvar name'
786 name' = tidyNameOcc name occ'
789 -----------------------------------
790 Other helper functions
793 add_err_tcm tidy_env err_msg loc ctxt
794 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
795 addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
799 do_ctxt tidy_env (c:cs)
800 = do { (tidy_env', m) <- c tidy_env ;
801 ms <- do_ctxt tidy_env' cs ;
804 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
805 | otherwise = take 3 ctxt
808 debugTc is useful for monadic debugging code
811 debugTc :: TcM () -> TcM ()
813 debugTc thing = thing
815 debugTc thing = return ()
819 %************************************************************************
821 Type constraints (the so-called LIE)
823 %************************************************************************
826 nextDFunIndex :: TcM Int -- Get the next dfun index
827 nextDFunIndex = do { env <- getGblEnv
828 ; let dfun_n_var = tcg_dfun_n env
829 ; n <- readMutVar dfun_n_var
830 ; writeMutVar dfun_n_var (n+1)
833 getLIEVar :: TcM (TcRef LIE)
834 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
836 setLIEVar :: TcRef LIE -> TcM a -> TcM a
837 setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
839 getLIE :: TcM a -> TcM (a, [Inst])
840 -- (getLIE m) runs m, and returns the type constraints it generates
842 = do { lie_var <- newMutVar emptyLIE ;
843 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
845 lie <- readMutVar lie_var ;
846 return (res, lieToList lie) }
848 extendLIE :: Inst -> TcM ()
850 = do { lie_var <- getLIEVar ;
851 lie <- readMutVar lie_var ;
852 writeMutVar lie_var (inst `consLIE` lie) }
854 extendLIEs :: [Inst] -> TcM ()
858 = do { lie_var <- getLIEVar ;
859 lie <- readMutVar lie_var ;
860 writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
864 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
865 -- Set the local type envt, but do *not* disturb other fields,
866 -- notably the lie_var
867 setLclTypeEnv lcl_env thing_inside
868 = updLclEnv upd thing_inside
870 upd env = env { tcl_env = tcl_env lcl_env,
871 tcl_tyvars = tcl_tyvars lcl_env }
875 %************************************************************************
877 Template Haskell context
879 %************************************************************************
882 recordThUse :: TcM ()
883 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
885 keepAliveTc :: Name -> TcM () -- Record the name in the keep-alive set
886 keepAliveTc n = do { env <- getGblEnv;
887 ; updMutVar (tcg_keep env) (`addOneToNameSet` n) }
889 keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set
890 keepAliveSetTc ns = do { env <- getGblEnv;
891 ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
893 getStage :: TcM ThStage
894 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
896 setStage :: ThStage -> TcM a -> TcM a
897 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
901 %************************************************************************
903 Stuff for the renamer's local env
905 %************************************************************************
908 getLocalRdrEnv :: RnM LocalRdrEnv
909 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
911 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
912 setLocalRdrEnv rdr_env thing_inside
913 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
917 %************************************************************************
919 Stuff for interface decls
921 %************************************************************************
924 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
925 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
927 if_tv_env = emptyOccEnv,
928 if_id_env = emptyOccEnv }
930 initIfaceTcRn :: IfG a -> TcRn a
931 initIfaceTcRn thing_inside
932 = do { tcg_env <- getGblEnv
933 ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
934 ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
935 ; setEnvs (if_env, ()) thing_inside }
937 initIfaceExtCore :: IfL a -> TcRn a
938 initIfaceExtCore thing_inside
939 = do { tcg_env <- getGblEnv
940 ; let { mod = tcg_mod tcg_env
941 ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
942 ; if_env = IfGblEnv {
943 if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
944 ; if_lenv = mkIfLclEnv mod doc
946 ; setEnvs (if_env, if_lenv) thing_inside }
948 initIfaceCheck :: HscEnv -> IfG a -> IO a
949 -- Used when checking the up-to-date-ness of the old Iface
950 -- Initialise the environment with no useful info at all
951 initIfaceCheck hsc_env do_this
952 = do { let gbl_env = IfGblEnv { if_rec_types = Nothing }
953 ; initTcRnIf 'i' hsc_env gbl_env () do_this
956 initIfaceTc :: ModIface
957 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
958 -- Used when type-checking checking an up-to-date interface file
959 -- No type envt from the current module, but we do know the module dependencies
960 initIfaceTc iface do_this
961 = do { tc_env_var <- newMutVar emptyTypeEnv
962 ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
963 ; if_lenv = mkIfLclEnv mod doc
965 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
968 mod = mi_module iface
969 doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
971 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
972 -- Used when sucking in new Rules in SimplCore
973 -- We have available the type envt of the module being compiled, and we must use it
974 initIfaceRules hsc_env guts do_this
976 type_info = (mg_module guts, return (mg_types guts))
977 ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
980 -- Run the thing; any exceptions just bubble out from here
981 ; initTcRnIf 'i' hsc_env gbl_env () do_this
984 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
985 initIfaceLcl mod loc_doc thing_inside
986 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
988 getIfModule :: IfL Module
989 getIfModule = do { env <- getLclEnv; return (if_mod env) }
992 failIfM :: Message -> IfL a
993 -- The Iface monad doesn't have a place to accumulate errors, so we
994 -- just fall over fast if one happens; it "shouldnt happen".
995 -- We use IfL here so that we can get context info out of the local env
997 = do { env <- getLclEnv
998 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
999 ; ioToIOEnv (printErrs (full_msg defaultErrStyle))
1002 --------------------
1003 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1004 -- Run thing_inside in an interleaved thread.
1005 -- It shares everything with the parent thread, so this is DANGEROUS.
1007 -- It returns Nothing if the computation fails
1009 -- It's used for lazily type-checking interface
1010 -- signatures, which is pretty benign
1012 forkM_maybe doc thing_inside
1013 = do { unsafeInterleaveM $
1014 do { traceIf (text "Starting fork {" <+> doc)
1016 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1019 Right r -> do { traceIf (text "} ending fork" <+> doc)
1023 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1024 -- Otherwise we silently discard errors. Errors can legitimately
1025 -- happen when compiling interface signatures (see tcInterfaceSigs)
1026 ifOptM Opt_D_dump_if_trace
1027 (print_errs (hang (text "forkM failed:" <+> doc)
1028 4 (text (show exn))))
1030 ; traceIf (text "} ending fork (badly)" <+> doc)
1034 print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle))
1036 forkM :: SDoc -> IfL a -> IfL a
1037 forkM doc thing_inside
1038 = do { mb_res <- forkM_maybe doc thing_inside
1039 ; return (case mb_res of
1040 Nothing -> pgmError "Cannot continue after interface file error"
1041 -- pprPanic "forkM" doc