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