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