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