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