Refactor wild card renaming
[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_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 failAt :: SrcSpan -> MsgDoc -> TcRn a
695 failAt loc msg = addErrAt loc msg >> failM
696
697 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
698 -- addErrAt is mainly (exclusively?) used by the renamer, where
699 -- tidying is not an issue, but it's all lazy so the extra
700 -- work doesn't matter
701 addErrAt loc msg = do { ctxt <- getErrCtxt
702 ; tidy_env <- tcInitTidyEnv
703 ; err_info <- mkErrInfo tidy_env ctxt
704 ; addLongErrAt loc msg err_info }
705
706 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
707 addErrs msgs = mapM_ add msgs
708 where
709 add (loc,msg) = addErrAt loc msg
710
711 checkErr :: Bool -> MsgDoc -> TcRn ()
712 -- Add the error if the bool is False
713 checkErr ok msg = unless ok (addErr msg)
714
715 warnIf :: Bool -> MsgDoc -> TcRn ()
716 warnIf True msg = addWarn msg
717 warnIf False _ = return ()
718
719 addMessages :: Messages -> TcRn ()
720 addMessages (m_warns, m_errs)
721 = do { errs_var <- getErrsVar ;
722 (warns, errs) <- readTcRef errs_var ;
723 writeTcRef errs_var (warns `unionBags` m_warns,
724 errs `unionBags` m_errs) }
725
726 discardWarnings :: TcRn a -> TcRn a
727 -- Ignore warnings inside the thing inside;
728 -- used to ignore-unused-variable warnings inside derived code
729 discardWarnings thing_inside
730 = do { errs_var <- getErrsVar
731 ; (old_warns, _) <- readTcRef errs_var ;
732
733 ; result <- thing_inside
734
735 -- Revert warnings to old_warns
736 ; (_new_warns, new_errs) <- readTcRef errs_var
737 ; writeTcRef errs_var (old_warns, new_errs)
738
739 ; return result }
740
741 {-
742 ************************************************************************
743 * *
744 Shared error message stuff: renamer and typechecker
745 * *
746 ************************************************************************
747 -}
748
749 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
750 mkLongErrAt loc msg extra
751 = do { dflags <- getDynFlags ;
752 printer <- getPrintUnqualified dflags ;
753 return $ mkLongErrMsg dflags loc printer msg extra }
754
755 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
756 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
757
758 reportErrors :: [ErrMsg] -> TcM ()
759 reportErrors = mapM_ reportError
760
761 reportError :: ErrMsg -> TcRn ()
762 reportError err
763 = do { traceTc "Adding error:" (pprLocErrMsg err) ;
764 errs_var <- getErrsVar ;
765 (warns, errs) <- readTcRef errs_var ;
766 writeTcRef errs_var (warns, errs `snocBag` err) }
767
768 reportWarning :: ErrMsg -> TcRn ()
769 reportWarning err
770 = do { let warn = makeIntoWarning err
771 -- 'err' was build by mkLongErrMsg or something like that,
772 -- so it's of error severity. For a warning we downgrade
773 -- its severity to SevWarning
774
775 ; traceTc "Adding warning:" (pprLocErrMsg warn)
776 ; errs_var <- getErrsVar
777 ; (warns, errs) <- readTcRef errs_var
778 ; writeTcRef errs_var (warns `snocBag` warn, errs) }
779
780 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
781 -- Does tryM, with a debug-trace on failure
782 try_m thing
783 = do { mb_r <- tryM thing ;
784 case mb_r of
785 Left exn -> do { traceTc "tryTc/recoverM recovering from" $
786 text (showException exn)
787 ; return mb_r }
788 Right _ -> return mb_r }
789
790 -----------------------
791 recoverM :: TcRn r -- Recovery action; do this if the main one fails
792 -> TcRn r -- Main action: do this first
793 -> TcRn r
794 -- Errors in 'thing' are retained
795 recoverM recover thing
796 = do { mb_res <- try_m thing ;
797 case mb_res of
798 Left _ -> recover
799 Right res -> return res }
800
801
802 -----------------------
803 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
804 -- Drop elements of the input that fail, so the result
805 -- list can be shorter than the argument list
806 mapAndRecoverM _ [] = return []
807 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
808 ; rs <- mapAndRecoverM f xs
809 ; return (case mb_r of
810 Left _ -> rs
811 Right r -> r:rs) }
812
813 -- | Succeeds if applying the argument to all members of the lists succeeds,
814 -- but nevertheless runs it on all arguments, to collect all errors.
815 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
816 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
817
818 -----------------------
819 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
820 -- (tryTc m) executes m, and returns
821 -- Just r, if m succeeds (returning r)
822 -- Nothing, if m fails
823 -- It also returns all the errors and warnings accumulated by m
824 -- It always succeeds (never raises an exception)
825 tryTc m
826 = do { errs_var <- newTcRef emptyMessages ;
827 res <- try_m (setErrsVar errs_var m) ;
828 msgs <- readTcRef errs_var ;
829 return (msgs, case res of
830 Left _ -> Nothing
831 Right val -> Just val)
832 -- The exception is always the IOEnv built-in
833 -- in exception; see IOEnv.failM
834 }
835
836 -----------------------
837 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
838 -- Run the thing, returning
839 -- Just r, if m succceeds with no error messages
840 -- Nothing, if m fails, or if it succeeds but has error messages
841 -- Either way, the messages are returned; even in the Just case
842 -- there might be warnings
843 tryTcErrs thing
844 = do { (msgs, res) <- tryTc thing
845 ; dflags <- getDynFlags
846 ; let errs_found = errorsFound dflags msgs
847 ; return (msgs, case res of
848 Nothing -> Nothing
849 Just val | errs_found -> Nothing
850 | otherwise -> Just val)
851 }
852
853 -----------------------
854 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
855 -- Just like tryTcErrs, except that it ensures that the LIE
856 -- for the thing is propagated only if there are no errors
857 -- Hence it's restricted to the type-check monad
858 tryTcLIE thing_inside
859 = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
860 ; case mb_res of
861 Nothing -> return (msgs, Nothing)
862 Just val -> do { emitConstraints lie; return (msgs, Just val) }
863 }
864
865 -----------------------
866 tryTcLIE_ :: TcM r -> TcM r -> TcM r
867 -- (tryTcLIE_ r m) tries m;
868 -- if m succeeds with no error messages, it's the answer
869 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
870 tryTcLIE_ recover main
871 = do { (msgs, mb_res) <- tryTcLIE main
872 ; case mb_res of
873 Just val -> do { addMessages msgs -- There might be warnings
874 ; return val }
875 Nothing -> recover -- Discard all msgs
876 }
877
878 -----------------------
879 checkNoErrs :: TcM r -> TcM r
880 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
881 -- If m fails then (checkNoErrsTc m) fails.
882 -- If m succeeds, it checks whether m generated any errors messages
883 -- (it might have recovered internally)
884 -- If so, it fails too.
885 -- Regardless, any errors generated by m are propagated to the enclosing context.
886 checkNoErrs main
887 = do { (msgs, mb_res) <- tryTcLIE main
888 ; addMessages msgs
889 ; case mb_res of
890 Nothing -> failM
891 Just val -> return val
892 }
893
894 whenNoErrs :: TcM () -> TcM ()
895 whenNoErrs thing = ifErrsM (return ()) thing
896
897 ifErrsM :: TcRn r -> TcRn r -> TcRn r
898 -- ifErrsM bale_out normal
899 -- does 'bale_out' if there are errors in errors collection
900 -- otherwise does 'normal'
901 ifErrsM bale_out normal
902 = do { errs_var <- getErrsVar ;
903 msgs <- readTcRef errs_var ;
904 dflags <- getDynFlags ;
905 if errorsFound dflags msgs then
906 bale_out
907 else
908 normal }
909
910 failIfErrsM :: TcRn ()
911 -- Useful to avoid error cascades
912 failIfErrsM = ifErrsM failM (return ())
913
914 #ifdef GHCI
915 checkTH :: a -> String -> TcRn ()
916 checkTH _ _ = return () -- OK
917 #else
918 checkTH :: Outputable a => a -> String -> TcRn ()
919 checkTH e what = failTH e what -- Raise an error in a stage-1 compiler
920 #endif
921
922 failTH :: Outputable a => a -> String -> TcRn x
923 failTH e what -- Raise an error in a stage-1 compiler
924 = failWithTc (vcat [ hang (char 'A' <+> text what
925 <+> ptext (sLit "requires GHC with interpreter support:"))
926 2 (ppr e)
927 , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
928
929 {-
930 ************************************************************************
931 * *
932 Context management for the type checker
933 * *
934 ************************************************************************
935 -}
936
937 getErrCtxt :: TcM [ErrCtxt]
938 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
939
940 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
941 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
942
943 addErrCtxt :: MsgDoc -> TcM a -> TcM a
944 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
945
946 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
947 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
948
949 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
950 addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
951
952 -- Helper function for the above
953 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
954 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
955 env { tcl_ctxt = upd ctxt })
956
957 popErrCtxt :: TcM a -> TcM a
958 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
959
960 getCtLoc :: CtOrigin -> TcM CtLoc
961 getCtLoc origin
962 = do { env <- getLclEnv
963 ; return (CtLoc { ctl_origin = origin
964 , ctl_env = env
965 , ctl_depth = initialSubGoalDepth }) }
966
967 setCtLoc :: CtLoc -> TcM a -> TcM a
968 -- Set the SrcSpan and error context from the CtLoc
969 setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
970 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
971 , tcl_bndrs = tcl_bndrs lcl
972 , tcl_ctxt = tcl_ctxt lcl })
973 thing_inside
974
975 {-
976 ************************************************************************
977 * *
978 Error message generation (type checker)
979 * *
980 ************************************************************************
981
982 The addErrTc functions add an error message, but do not cause failure.
983 The 'M' variants pass a TidyEnv that has already been used to
984 tidy up the message; we then use it to tidy the context messages
985 -}
986
987 addErrTc :: MsgDoc -> TcM ()
988 addErrTc err_msg = do { env0 <- tcInitTidyEnv
989 ; addErrTcM (env0, err_msg) }
990
991 addErrsTc :: [MsgDoc] -> TcM ()
992 addErrsTc err_msgs = mapM_ addErrTc err_msgs
993
994 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
995 addErrTcM (tidy_env, err_msg)
996 = do { ctxt <- getErrCtxt ;
997 loc <- getSrcSpanM ;
998 add_err_tcm tidy_env err_msg loc ctxt }
999
1000 -- Return the error message, instead of reporting it straight away
1001 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1002 mkErrTcM (tidy_env, err_msg)
1003 = do { ctxt <- getErrCtxt ;
1004 loc <- getSrcSpanM ;
1005 err_info <- mkErrInfo tidy_env ctxt ;
1006 mkLongErrAt loc err_msg err_info }
1007
1008 -- The failWith functions add an error message and cause failure
1009
1010 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
1011 failWithTc err_msg
1012 = addErrTc err_msg >> failM
1013
1014 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1015 failWithTcM local_and_msg
1016 = addErrTcM local_and_msg >> failM
1017
1018 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1019 checkTc True _ = return ()
1020 checkTc False err = failWithTc err
1021
1022 failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
1023 failIfTc False _ = return ()
1024 failIfTc True err = failWithTc err
1025
1026 -- Warnings have no 'M' variant, nor failure
1027
1028 warnTc :: Bool -> MsgDoc -> TcM ()
1029 warnTc warn_if_true warn_msg
1030 | warn_if_true = addWarnTc warn_msg
1031 | otherwise = return ()
1032
1033 addWarnTc :: MsgDoc -> TcM ()
1034 addWarnTc msg = do { env0 <- tcInitTidyEnv
1035 ; addWarnTcM (env0, msg) }
1036
1037 addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
1038 addWarnTcM (env0, msg)
1039 = do { ctxt <- getErrCtxt ;
1040 err_info <- mkErrInfo env0 ctxt ;
1041 add_warn msg err_info }
1042
1043 addWarn :: MsgDoc -> TcRn ()
1044 addWarn msg = add_warn msg Outputable.empty
1045
1046 addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
1047 addWarnAt loc msg = add_warn_at loc msg Outputable.empty
1048
1049 add_warn :: MsgDoc -> MsgDoc -> TcRn ()
1050 add_warn msg extra_info
1051 = do { loc <- getSrcSpanM
1052 ; add_warn_at loc msg extra_info }
1053
1054 add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1055 add_warn_at loc msg extra_info
1056 = do { dflags <- getDynFlags ;
1057 printer <- getPrintUnqualified dflags ;
1058 let { warn = mkLongWarnMsg dflags loc printer
1059 msg extra_info } ;
1060 reportWarning warn }
1061
1062 tcInitTidyEnv :: TcM TidyEnv
1063 tcInitTidyEnv
1064 = do { lcl_env <- getLclEnv
1065 ; return (tcl_tidy lcl_env) }
1066
1067 {-
1068 -----------------------------------
1069 Other helper functions
1070 -}
1071
1072 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1073 -> [ErrCtxt]
1074 -> TcM ()
1075 add_err_tcm tidy_env err_msg loc ctxt
1076 = do { err_info <- mkErrInfo tidy_env ctxt ;
1077 addLongErrAt loc err_msg err_info }
1078
1079 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1080 -- Tidy the error info, trimming excessive contexts
1081 mkErrInfo env ctxts
1082 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1083 -- = return empty -- just becomes too voluminous
1084 | otherwise
1085 = go 0 env ctxts
1086 where
1087 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1088 go _ _ [] = return Outputable.empty
1089 go n env ((is_landmark, ctxt) : ctxts)
1090 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1091 = do { (env', msg) <- ctxt env
1092 ; let n' = if is_landmark then n else n+1
1093 ; rest <- go n' env' ctxts
1094 ; return (msg $$ rest) }
1095 | otherwise
1096 = go n env ctxts
1097
1098 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1099 mAX_CONTEXTS = 3
1100
1101 -- debugTc is useful for monadic debugging code
1102
1103 debugTc :: TcM () -> TcM ()
1104 debugTc thing
1105 | debugIsOn = thing
1106 | otherwise = return ()
1107
1108 {-
1109 ************************************************************************
1110 * *
1111 Type constraints
1112 * *
1113 ************************************************************************
1114 -}
1115
1116 newTcEvBinds :: TcM EvBindsVar
1117 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1118 ; uniq <- newUnique
1119 ; return (EvBindsVar ref uniq) }
1120
1121 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1122 -- Add a binding to the TcEvBinds by side effect
1123 addTcEvBind (EvBindsVar ev_ref _) ev_bind
1124 = do { traceTc "addTcEvBind" $ ppr ev_bind
1125 ; bnds <- readTcRef ev_ref
1126 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1127
1128 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1129 getTcEvBinds (EvBindsVar ev_ref _)
1130 = do { bnds <- readTcRef ev_ref
1131 ; return (evBindMapBinds bnds) }
1132
1133 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1134 chooseUniqueOccTc fn =
1135 do { env <- getGblEnv
1136 ; let dfun_n_var = tcg_dfun_n env
1137 ; set <- readTcRef dfun_n_var
1138 ; let occ = fn set
1139 ; writeTcRef dfun_n_var (extendOccSet set occ)
1140 ; return occ }
1141
1142 getConstraintVar :: TcM (TcRef WantedConstraints)
1143 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1144
1145 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1146 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1147
1148 emitConstraints :: WantedConstraints -> TcM ()
1149 emitConstraints ct
1150 = do { lie_var <- getConstraintVar ;
1151 updTcRef lie_var (`andWC` ct) }
1152
1153 emitSimple :: Ct -> TcM ()
1154 emitSimple ct
1155 = do { lie_var <- getConstraintVar ;
1156 updTcRef lie_var (`addSimples` unitBag ct) }
1157
1158 emitSimples :: Cts -> TcM ()
1159 emitSimples cts
1160 = do { lie_var <- getConstraintVar ;
1161 updTcRef lie_var (`addSimples` cts) }
1162
1163 emitImplication :: Implication -> TcM ()
1164 emitImplication ct
1165 = do { lie_var <- getConstraintVar ;
1166 updTcRef lie_var (`addImplics` unitBag ct) }
1167
1168 emitImplications :: Bag Implication -> TcM ()
1169 emitImplications ct
1170 = do { lie_var <- getConstraintVar ;
1171 updTcRef lie_var (`addImplics` ct) }
1172
1173 emitInsoluble :: Ct -> TcM ()
1174 emitInsoluble ct
1175 = do { lie_var <- getConstraintVar ;
1176 updTcRef lie_var (`addInsols` unitBag ct) ;
1177 v <- readTcRef lie_var ;
1178 traceTc "emitInsoluble" (ppr v) }
1179
1180 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1181 -- (captureConstraints m) runs m, and returns the type constraints it generates
1182 captureConstraints thing_inside
1183 = do { lie_var <- newTcRef emptyWC ;
1184 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1185 thing_inside ;
1186 lie <- readTcRef lie_var ;
1187 return (res, lie) }
1188
1189 pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints)
1190 pushLevelAndCaptureConstraints thing_inside
1191 = do { env <- getLclEnv
1192 ; lie_var <- newTcRef emptyWC ;
1193 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1194 ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1195 , tcl_lie = lie_var })
1196 thing_inside
1197 ; lie <- readTcRef lie_var
1198 ; return (res, tclvl', lie) }
1199
1200 pushTcLevelM_ :: TcM a -> TcM a
1201 pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) })
1202
1203 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1204 pushTcLevelM thing_inside
1205 = do { env <- getLclEnv
1206 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1207 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1208 thing_inside
1209 ; return (res, tclvl') }
1210
1211 getTcLevel :: TcM TcLevel
1212 getTcLevel = do { env <- getLclEnv
1213 ; return (tcl_tclvl env) }
1214
1215 setTcLevel :: TcLevel -> TcM a -> TcM a
1216 setTcLevel tclvl thing_inside
1217 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1218
1219 isTouchableTcM :: TcTyVar -> TcM Bool
1220 isTouchableTcM tv
1221 = do { env <- getLclEnv
1222 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1223
1224 getLclTypeEnv :: TcM TcTypeEnv
1225 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1226
1227 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1228 -- Set the local type envt, but do *not* disturb other fields,
1229 -- notably the lie_var
1230 setLclTypeEnv lcl_env thing_inside
1231 = updLclEnv upd thing_inside
1232 where
1233 upd env = env { tcl_env = tcl_env lcl_env,
1234 tcl_tyvars = tcl_tyvars lcl_env }
1235
1236 traceTcConstraints :: String -> TcM ()
1237 traceTcConstraints msg
1238 = do { lie_var <- getConstraintVar
1239 ; lie <- readTcRef lie_var
1240 ; traceTc (msg ++ ": LIE:") (ppr lie)
1241 }
1242
1243 emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1244 emitWildcardHoleConstraints wcs
1245 = do { ctLoc <- getCtLoc HoleOrigin
1246 ; forM_ wcs $ \(name, tv) -> do {
1247 ; let real_span = case nameSrcSpan name of
1248 RealSrcSpan span -> span
1249 UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints"
1250 (ppr name <+> quotes (ftext str))
1251 -- Wildcards are defined locally, and so have RealSrcSpans
1252 ctLoc' = setCtLocSpan ctLoc real_span
1253 ty = mkTyVarTy tv
1254 ev = mkLocalId name ty
1255 can = CHoleCan { cc_ev = CtWanted ty ev ctLoc'
1256 , cc_occ = occName name
1257 , cc_hole = TypeHole }
1258 ; emitInsoluble can } }
1259
1260 {-
1261 ************************************************************************
1262 * *
1263 Template Haskell context
1264 * *
1265 ************************************************************************
1266 -}
1267
1268 recordThUse :: TcM ()
1269 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1270
1271 recordThSpliceUse :: TcM ()
1272 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1273
1274 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1275 keepAlive name
1276 = do { env <- getGblEnv
1277 ; traceRn (ptext (sLit "keep alive") <+> ppr name)
1278 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1279
1280 getStage :: TcM ThStage
1281 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1282
1283 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1284 getStageAndBindLevel name
1285 = do { env <- getLclEnv;
1286 ; case lookupNameEnv (tcl_th_bndrs env) name of
1287 Nothing -> return Nothing
1288 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1289
1290 setStage :: ThStage -> TcM a -> TcRn a
1291 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1292
1293 {-
1294 ************************************************************************
1295 * *
1296 Safe Haskell context
1297 * *
1298 ************************************************************************
1299 -}
1300
1301 -- | Mark that safe inference has failed
1302 -- See Note [Safe Haskell Overlapping Instances Implementation]
1303 -- although this is used for more than just that failure case.
1304 recordUnsafeInfer :: WarningMessages -> TcM ()
1305 recordUnsafeInfer warns =
1306 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1307
1308 -- | Figure out the final correct safe haskell mode
1309 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1310 finalSafeMode dflags tcg_env = do
1311 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1312 return $ case safeHaskell dflags of
1313 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1314 | otherwise -> Sf_None
1315 s -> s
1316
1317 -- | Switch instances to safe instances if we're in Safe mode.
1318 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1319 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1320 fixSafeInstances _ = map fixSafe
1321 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1322 in inst { is_flag = new_flag }
1323
1324 {-
1325 ************************************************************************
1326 * *
1327 Stuff for the renamer's local env
1328 * *
1329 ************************************************************************
1330 -}
1331
1332 getLocalRdrEnv :: RnM LocalRdrEnv
1333 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1334
1335 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1336 setLocalRdrEnv rdr_env thing_inside
1337 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1338
1339 {-
1340 ************************************************************************
1341 * *
1342 Stuff for interface decls
1343 * *
1344 ************************************************************************
1345 -}
1346
1347 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1348 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
1349 if_loc = loc,
1350 if_tv_env = emptyUFM,
1351 if_id_env = emptyUFM }
1352
1353 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1354 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1355 -- based on 'TcGblEnv'.
1356 initIfaceTcRn :: IfG a -> TcRn a
1357 initIfaceTcRn thing_inside
1358 = do { tcg_env <- getGblEnv
1359 ; let { if_env = IfGblEnv {
1360 if_rec_types = Just (tcg_mod tcg_env, get_type_env)
1361 }
1362 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1363 ; setEnvs (if_env, ()) thing_inside }
1364
1365 initIfaceCheck :: HscEnv -> IfG a -> IO a
1366 -- Used when checking the up-to-date-ness of the old Iface
1367 -- Initialise the environment with no useful info at all
1368 initIfaceCheck hsc_env do_this
1369 = do let rec_types = case hsc_type_env_var hsc_env of
1370 Just (mod,var) -> Just (mod, readTcRef var)
1371 Nothing -> Nothing
1372 gbl_env = IfGblEnv { if_rec_types = rec_types }
1373 initTcRnIf 'i' hsc_env gbl_env () do_this
1374
1375 initIfaceTc :: ModIface
1376 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1377 -- Used when type-checking checking an up-to-date interface file
1378 -- No type envt from the current module, but we do know the module dependencies
1379 initIfaceTc iface do_this
1380 = do { tc_env_var <- newTcRef emptyTypeEnv
1381 ; let { gbl_env = IfGblEnv {
1382 if_rec_types = Just (mod, readTcRef tc_env_var)
1383 } ;
1384 ; if_lenv = mkIfLclEnv mod doc
1385 }
1386 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1387 }
1388 where
1389 mod = mi_module iface
1390 doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1391
1392 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1393 initIfaceLcl mod loc_doc thing_inside
1394 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1395
1396 getIfModule :: IfL Module
1397 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1398
1399 --------------------
1400 failIfM :: MsgDoc -> IfL a
1401 -- The Iface monad doesn't have a place to accumulate errors, so we
1402 -- just fall over fast if one happens; it "shouldnt happen".
1403 -- We use IfL here so that we can get context info out of the local env
1404 failIfM msg
1405 = do { env <- getLclEnv
1406 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1407 ; dflags <- getDynFlags
1408 ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
1409 ; failM }
1410
1411 --------------------
1412 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1413 -- Run thing_inside in an interleaved thread.
1414 -- It shares everything with the parent thread, so this is DANGEROUS.
1415 --
1416 -- It returns Nothing if the computation fails
1417 --
1418 -- It's used for lazily type-checking interface
1419 -- signatures, which is pretty benign
1420
1421 forkM_maybe doc thing_inside
1422 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1423 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1424 = do { child_us <- newUniqueSupply
1425 ; child_env_us <- newMutVar child_us
1426 -- see Note [Masking exceptions in forkM_maybe]
1427 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1428 do { traceIf (text "Starting fork {" <+> doc)
1429 ; mb_res <- tryM $
1430 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1431 thing_inside
1432 ; case mb_res of
1433 Right r -> do { traceIf (text "} ending fork" <+> doc)
1434 ; return (Just r) }
1435 Left exn -> do {
1436
1437 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1438 -- Otherwise we silently discard errors. Errors can legitimately
1439 -- happen when compiling interface signatures (see tcInterfaceSigs)
1440 whenDOptM Opt_D_dump_if_trace $ do
1441 dflags <- getDynFlags
1442 let msg = hang (text "forkM failed:" <+> doc)
1443 2 (text (show exn))
1444 liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
1445
1446 ; traceIf (text "} ending fork (badly)" <+> doc)
1447 ; return Nothing }
1448 }}
1449
1450 forkM :: SDoc -> IfL a -> IfL a
1451 forkM doc thing_inside
1452 = do { mb_res <- forkM_maybe doc thing_inside
1453 ; return (case mb_res of
1454 Nothing -> pgmError "Cannot continue after interface file error"
1455 -- pprPanic "forkM" doc
1456 Just r -> r) }
1457
1458 {-
1459 Note [Masking exceptions in forkM_maybe]
1460 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1461
1462 When using GHC-as-API it must be possible to interrupt snippets of code
1463 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1464 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1465 subtle problem: runStmt first typechecks the code before running it, and the
1466 exception might interrupt the type checker rather than the code. Moreover, the
1467 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1468 more importantly might be inside an exception handler inside that
1469 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1470 asynchronous exception as a synchronous exception, and the exception will end
1471 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1472 discussion). We don't currently know a general solution to this problem, but
1473 we can use uninterruptibleMask_ to avoid the situation.
1474 -}