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