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