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