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