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