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