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