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