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