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