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