Refactor the typechecker to use ExpTypes.
[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
60 #ifdef GHCI
61 import qualified Data.Map as Map
62 #endif
63
64 {-
65 ************************************************************************
66 * *
67 initTc
68 * *
69 ************************************************************************
70 -}
71
72 -- | Setup the initial typechecking environment
73 initTc :: HscEnv
74 -> HscSource
75 -> Bool -- True <=> retain renamed syntax trees
76 -> Module
77 -> RealSrcSpan
78 -> TcM r
79 -> IO (Messages, Maybe r)
80 -- Nothing => error thrown by the thing inside
81 -- (error messages should have been printed already)
82
83 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
84 = do { errs_var <- newIORef (emptyBag, emptyBag) ;
85 tvs_var <- newIORef emptyVarSet ;
86 keep_var <- newIORef emptyNameSet ;
87 used_gre_var <- newIORef [] ;
88 th_var <- newIORef False ;
89 th_splice_var<- newIORef False ;
90 infer_var <- newIORef (True, emptyBag) ;
91 lie_var <- newIORef emptyWC ;
92 dfun_n_var <- newIORef emptyOccSet ;
93 type_env_var <- case hsc_type_env_var hsc_env of {
94 Just (_mod, te_var) -> return te_var ;
95 Nothing -> newIORef emptyNameEnv } ;
96
97 dependent_files_var <- newIORef [] ;
98 static_wc_var <- newIORef emptyWC ;
99 #ifdef GHCI
100 th_topdecls_var <- newIORef [] ;
101 th_topnames_var <- newIORef emptyNameSet ;
102 th_modfinalizers_var <- newIORef [] ;
103 th_state_var <- newIORef Map.empty ;
104 th_remote_state_var <- newIORef Nothing ;
105 #endif /* GHCI */
106 let {
107 dflags = hsc_dflags hsc_env ;
108
109 maybe_rn_syntax :: forall a. a -> Maybe a ;
110 maybe_rn_syntax empty_val
111 | keep_rn_syntax = Just empty_val
112 | otherwise = Nothing ;
113
114 gbl_env = TcGblEnv {
115 #ifdef GHCI
116 tcg_th_topdecls = th_topdecls_var,
117 tcg_th_topnames = th_topnames_var,
118 tcg_th_modfinalizers = th_modfinalizers_var,
119 tcg_th_state = th_state_var,
120 tcg_th_remote_state = th_remote_state_var,
121 #endif /* GHCI */
122
123 tcg_mod = mod,
124 tcg_src = hsc_src,
125 tcg_sig_of = getSigOf dflags (moduleName mod),
126 tcg_impl_rdr_env = Nothing,
127 tcg_rdr_env = emptyGlobalRdrEnv,
128 tcg_fix_env = emptyNameEnv,
129 tcg_field_env = emptyNameEnv,
130 tcg_default = if moduleUnitId mod == primUnitId
131 then Just [] -- See Note [Default types]
132 else Nothing,
133 tcg_type_env = emptyNameEnv,
134 tcg_type_env_var = type_env_var,
135 tcg_inst_env = emptyInstEnv,
136 tcg_fam_inst_env = emptyFamInstEnv,
137 tcg_ann_env = emptyAnnEnv,
138 tcg_th_used = th_var,
139 tcg_th_splice_used = th_splice_var,
140 tcg_exports = [],
141 tcg_imports = emptyImportAvails,
142 tcg_used_gres = used_gre_var,
143 tcg_dus = emptyDUs,
144
145 tcg_rn_imports = [],
146 tcg_rn_exports = maybe_rn_syntax [],
147 tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
148 tcg_tr_module = Nothing,
149 tcg_binds = emptyLHsBinds,
150 tcg_imp_specs = [],
151 tcg_sigs = emptyNameSet,
152 tcg_ev_binds = emptyBag,
153 tcg_warns = NoWarnings,
154 tcg_anns = [],
155 tcg_tcs = [],
156 tcg_insts = [],
157 tcg_fam_insts = [],
158 tcg_rules = [],
159 tcg_fords = [],
160 tcg_vects = [],
161 tcg_patsyns = [],
162 tcg_dfun_n = dfun_n_var,
163 tcg_keep = keep_var,
164 tcg_doc_hdr = Nothing,
165 tcg_hpc = False,
166 tcg_main = Nothing,
167 tcg_self_boot = NoSelfBoot,
168 tcg_safeInfer = infer_var,
169 tcg_dependent_files = dependent_files_var,
170 tcg_tc_plugins = [],
171 tcg_static_wc = static_wc_var
172 } ;
173 lcl_env = TcLclEnv {
174 tcl_errs = errs_var,
175 tcl_loc = loc, -- Should be over-ridden very soon!
176 tcl_ctxt = [],
177 tcl_rdr = emptyLocalRdrEnv,
178 tcl_th_ctxt = topStage,
179 tcl_th_bndrs = emptyNameEnv,
180 tcl_arrow_ctxt = NoArrowCtxt,
181 tcl_env = emptyNameEnv,
182 tcl_bndrs = [],
183 tcl_tidy = emptyTidyEnv,
184 tcl_tyvars = tvs_var,
185 tcl_lie = lie_var,
186 tcl_tclvl = topTcLevel
187 } ;
188 } ;
189
190 -- OK, here's the business end!
191 maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
192 do { r <- tryM do_this
193 ; case r of
194 Right res -> return (Just res)
195 Left _ -> return Nothing } ;
196
197 -- Check for unsolved constraints
198 lie <- readIORef lie_var ;
199 if isEmptyWC lie
200 then return ()
201 else pprPanic "initTc: unsolved constraints" (ppr lie) ;
202
203 -- Collect any error messages
204 msgs <- readIORef errs_var ;
205
206 let { final_res | errorsFound dflags msgs = Nothing
207 | otherwise = maybe_res } ;
208
209 return (msgs, final_res)
210 }
211
212
213 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
214 -- Initialise the type checker monad for use in GHCi
215 initTcInteractive hsc_env thing_inside
216 = initTc hsc_env HsSrcFile False
217 (icInteractiveModule (hsc_IC hsc_env))
218 (realSrcLocSpan interactive_src_loc)
219 thing_inside
220 where
221 interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
222
223 initTcForLookup :: HscEnv -> TcM a -> IO a
224 -- The thing_inside is just going to look up something
225 -- in the environment, so we don't need much setup
226 initTcForLookup hsc_env thing_inside
227 = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
228 ; case m of
229 Nothing -> throwIO $ mkSrcErr $ snd msgs
230 Just x -> return x }
231
232 {- Note [Default types]
233 ~~~~~~~~~~~~~~~~~~~~~~~
234 The Integer type is simply not available in package ghc-prim (it is
235 declared in integer-gmp). So we set the defaulting types to (Just
236 []), meaning there are no default types, rather then Nothing, which
237 means "use the default default types of Integer, Double".
238
239 If you don't do this, attempted defaulting in package ghc-prim causes
240 an actual crash (attempting to look up the Integer type).
241
242
243 ************************************************************************
244 * *
245 Initialisation
246 * *
247 ************************************************************************
248 -}
249
250 initTcRnIf :: Char -- Tag for unique supply
251 -> HscEnv
252 -> gbl -> lcl
253 -> TcRnIf gbl lcl a
254 -> IO a
255 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
256 = do { us <- mkSplitUniqSupply uniq_tag ;
257 ; us_var <- newIORef us ;
258
259 ; let { env = Env { env_top = hsc_env,
260 env_us = us_var,
261 env_gbl = gbl_env,
262 env_lcl = lcl_env} }
263
264 ; runIOEnv env thing_inside
265 }
266
267 {-
268 ************************************************************************
269 * *
270 Simple accessors
271 * *
272 ************************************************************************
273 -}
274
275 discardResult :: TcM a -> TcM ()
276 discardResult a = a >> return ()
277
278 getTopEnv :: TcRnIf gbl lcl HscEnv
279 getTopEnv = do { env <- getEnv; return (env_top env) }
280
281 updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
282 updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
283 env { env_top = upd top })
284
285 getGblEnv :: TcRnIf gbl lcl gbl
286 getGblEnv = do { env <- getEnv; return (env_gbl env) }
287
288 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
289 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
290 env { env_gbl = upd gbl })
291
292 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
293 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
294
295 getLclEnv :: TcRnIf gbl lcl lcl
296 getLclEnv = do { env <- getEnv; return (env_lcl env) }
297
298 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
299 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
300 env { env_lcl = upd lcl })
301
302 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
303 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
304
305 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
306 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
307
308 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
309 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
310
311 -- Command-line flags
312
313 xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
314 xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
315
316 doptM :: DumpFlag -> TcRnIf gbl lcl Bool
317 doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
318
319 goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
320 goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
321
322 woptM :: WarningFlag -> TcRnIf gbl lcl Bool
323 woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
324
325 setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
326 setXOptM flag =
327 updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
328
329 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
330 unsetGOptM flag =
331 updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
332
333 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
334 unsetWOptM flag =
335 updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
336
337 -- | Do it flag is true
338 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
339 whenDOptM flag thing_inside = do b <- doptM flag
340 when b thing_inside
341
342 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
343 whenGOptM flag thing_inside = do b <- goptM flag
344 when b thing_inside
345
346 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
347 whenWOptM flag thing_inside = do b <- woptM flag
348 when b thing_inside
349
350 whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
351 whenXOptM flag thing_inside = do b <- xoptM flag
352 when b thing_inside
353
354 getGhcMode :: TcRnIf gbl lcl GhcMode
355 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
356
357 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
358 withDoDynamicToo =
359 updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
360 top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
361
362 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
363 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
364
365 getEps :: TcRnIf gbl lcl ExternalPackageState
366 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
367
368 -- | Update the external package state. Returns the second result of the
369 -- modifier function.
370 --
371 -- This is an atomic operation and forces evaluation of the modified EPS in
372 -- order to avoid space leaks.
373 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
374 -> TcRnIf gbl lcl a
375 updateEps upd_fn = do
376 traceIf (text "updating EPS")
377 eps_var <- getEpsVar
378 atomicUpdMutVar' eps_var upd_fn
379
380 -- | Update the external package state.
381 --
382 -- This is an atomic operation and forces evaluation of the modified EPS in
383 -- order to avoid space leaks.
384 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
385 -> TcRnIf gbl lcl ()
386 updateEps_ upd_fn = do
387 traceIf (text "updating EPS_")
388 eps_var <- getEpsVar
389 atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
390
391 getHpt :: TcRnIf gbl lcl HomePackageTable
392 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
393
394 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
395 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
396 ; return (eps, hsc_HPT env) }
397
398 {-
399 ************************************************************************
400 * *
401 Arrow scopes
402 * *
403 ************************************************************************
404 -}
405
406 newArrowScope :: TcM a -> TcM a
407 newArrowScope
408 = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
409
410 -- Return to the stored environment (from the enclosing proc)
411 escapeArrowScope :: TcM a -> TcM a
412 escapeArrowScope
413 = updLclEnv $ \ env ->
414 case tcl_arrow_ctxt env of
415 NoArrowCtxt -> env
416 ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
417 , tcl_lie = lie
418 , tcl_rdr = rdr_env }
419
420 {-
421 ************************************************************************
422 * *
423 Unique supply
424 * *
425 ************************************************************************
426 -}
427
428 newUnique :: TcRnIf gbl lcl Unique
429 newUnique
430 = do { env <- getEnv ;
431 let { u_var = env_us env } ;
432 us <- readMutVar u_var ;
433 case takeUniqFromSupply us of { (uniq, us') -> do {
434 writeMutVar u_var us' ;
435 return $! uniq }}}
436 -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
437 -- a chain of unevaluated supplies behind.
438 -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
439 -- throw away one half of the new split supply. This is safe because this
440 -- is the only place we use that unique. Using the other half of the split
441 -- supply is safer, but slower.
442
443 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
444 newUniqueSupply
445 = do { env <- getEnv ;
446 let { u_var = env_us env } ;
447 us <- readMutVar u_var ;
448 case splitUniqSupply us of { (us1,us2) -> do {
449 writeMutVar u_var us1 ;
450 return us2 }}}
451
452 newLocalName :: Name -> TcM Name
453 newLocalName name = newName (nameOccName name)
454
455 newName :: OccName -> TcM Name
456 newName occ
457 = do { uniq <- newUnique
458 ; loc <- getSrcSpanM
459 ; return (mkInternalName uniq occ loc) }
460
461 newSysName :: OccName -> TcRnIf gbl lcl Name
462 newSysName occ
463 = do { uniq <- newUnique
464 ; return (mkSystemName uniq occ) }
465
466 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
467 newSysLocalId fs ty
468 = do { u <- newUnique
469 ; return (mkSysLocalOrCoVar fs u ty) }
470
471 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
472 newSysLocalIds fs tys
473 = do { us <- newUniqueSupply
474 ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
475
476 instance MonadUnique (IOEnv (Env gbl lcl)) where
477 getUniqueM = newUnique
478 getUniqueSupplyM = newUniqueSupply
479
480 {-
481 ************************************************************************
482 * *
483 Accessing input/output
484 * *
485 ************************************************************************
486 -}
487
488 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
489 newTcRef = newMutVar
490
491 readTcRef :: TcRef a -> TcRnIf gbl lcl a
492 readTcRef = readMutVar
493
494 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
495 writeTcRef = writeMutVar
496
497 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
498 -- Returns ()
499 updTcRef ref fn = liftIO $ do { old <- readIORef ref
500 ; writeIORef ref (fn old) }
501
502 updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
503 -- Returns previous value
504 updTcRefX ref fn = liftIO $ do { old <- readIORef ref
505 ; writeIORef ref (fn old)
506 ; return old }
507
508 {-
509 ************************************************************************
510 * *
511 Debugging
512 * *
513 ************************************************************************
514 -}
515
516 traceTc :: String -> SDoc -> TcRn ()
517 traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
518
519 -- | Typechecker trace
520 traceTcN :: Int -> SDoc -> TcRn ()
521 traceTcN level doc
522 = do dflags <- getDynFlags
523 when (level <= traceLevel dflags && not opt_NoDebugOutput) $
524 traceOptTcRn Opt_D_dump_tc_trace doc
525
526 traceRn :: SDoc -> TcRn ()
527 traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
528
529 -- | Output a doc if the given 'DumpFlag' is set.
530 --
531 -- By default this logs to stdout
532 -- However, if the `-ddump-to-file` flag is set,
533 -- then this will dump output to a file
534 --
535 -- Just a wrapper for 'dumpSDoc'
536 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
537 traceOptTcRn flag doc
538 = do { dflags <- getDynFlags
539 ; when (dopt flag dflags) (traceTcRn flag doc)
540 }
541
542 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
543 -- ^ Unconditionally dump some trace output
544 --
545 -- The DumpFlag is used only to set the output filename
546 -- for --dump-to-file, not to decide whether or not to output
547 -- That part is done by the caller
548 traceTcRn flag doc
549 = do { real_doc <- prettyDoc doc
550 ; dflags <- getDynFlags
551 ; printer <- getPrintUnqualified dflags
552 ; liftIO $ dumpSDoc dflags printer flag "" real_doc }
553 where
554 -- Add current location if opt_PprStyle_Debug
555 prettyDoc :: SDoc -> TcRn SDoc
556 prettyDoc doc = if opt_PprStyle_Debug
557 then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
558 else return doc -- The full location is usually way too much
559
560
561 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
562 getPrintUnqualified dflags
563 = do { rdr_env <- getGlobalRdrEnv
564 ; return $ mkPrintUnqualified dflags rdr_env }
565
566 -- | Like logInfoTcRn, but for user consumption
567 printForUserTcRn :: SDoc -> TcRn ()
568 printForUserTcRn doc
569 = do { dflags <- getDynFlags
570 ; printer <- getPrintUnqualified dflags
571 ; liftIO (printOutputForUser dflags printer doc) }
572
573 -- | Typechecker debug
574 debugDumpTcRn :: SDoc -> TcRn ()
575 debugDumpTcRn doc = unless opt_NoDebugOutput $
576 traceOptTcRn Opt_D_dump_tc doc
577
578 {-
579 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
580 available. Alas, they behave inconsistently with the other stuff;
581 e.g. are unaffected by -dump-to-file.
582 -}
583
584 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
585 traceIf = traceOptIf Opt_D_dump_if_trace
586 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
587
588
589 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
590 traceOptIf flag doc
591 = whenDOptM flag $ -- No RdrEnv available, so qualify everything
592 do { dflags <- getDynFlags
593 ; liftIO (putMsg dflags doc) }
594
595 {-
596 ************************************************************************
597 * *
598 Typechecker global environment
599 * *
600 ************************************************************************
601 -}
602
603 setModule :: Module -> TcRn a -> TcRn a
604 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
605
606 getIsGHCi :: TcRn Bool
607 getIsGHCi = do { mod <- getModule
608 ; return (isInteractiveModule mod) }
609
610 getGHCiMonad :: TcRn Name
611 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
612
613 getInteractivePrintName :: TcRn Name
614 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
615
616 tcIsHsBootOrSig :: TcRn Bool
617 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
618
619 tcSelfBootInfo :: TcRn SelfBootInfo
620 tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
621
622 getGlobalRdrEnv :: TcRn GlobalRdrEnv
623 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
624
625 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
626 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
627
628 getImports :: TcRn ImportAvails
629 getImports = do { env <- getGblEnv; return (tcg_imports env) }
630
631 getFixityEnv :: TcRn FixityEnv
632 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
633
634 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
635 extendFixityEnv new_bit
636 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
637 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
638
639 getRecFieldEnv :: TcRn RecFieldEnv
640 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
641
642 getDeclaredDefaultTys :: TcRn (Maybe [Type])
643 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
644
645 addDependentFiles :: [FilePath] -> TcRn ()
646 addDependentFiles fs = do
647 ref <- fmap tcg_dependent_files getGblEnv
648 dep_files <- readTcRef ref
649 writeTcRef ref (fs ++ dep_files)
650
651 {-
652 ************************************************************************
653 * *
654 Error management
655 * *
656 ************************************************************************
657 -}
658
659 getSrcSpanM :: TcRn SrcSpan
660 -- Avoid clash with Name.getSrcLoc
661 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
662
663 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
664 setSrcSpan (RealSrcSpan real_loc) thing_inside
665 = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
666 -- Don't overwrite useful info with useless:
667 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
668
669 addLocM :: (a -> TcM b) -> Located a -> TcM b
670 addLocM fn (L loc a) = setSrcSpan loc $ fn a
671
672 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
673 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
674
675 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
676 wrapLocFstM fn (L loc a) =
677 setSrcSpan loc $ do
678 (b,c) <- fn a
679 return (L loc b, c)
680
681 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
682 wrapLocSndM fn (L loc a) =
683 setSrcSpan loc $ do
684 (b,c) <- fn a
685 return (b, L loc c)
686
687 -- Reporting errors
688
689 getErrsVar :: TcRn (TcRef Messages)
690 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
691
692 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
693 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
694
695 addErr :: MsgDoc -> TcRn ()
696 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
697
698 failWith :: MsgDoc -> TcRn a
699 failWith msg = addErr msg >> failM
700
701 failAt :: SrcSpan -> MsgDoc -> TcRn a
702 failAt loc msg = addErrAt loc msg >> failM
703
704 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
705 -- addErrAt is mainly (exclusively?) used by the renamer, where
706 -- tidying is not an issue, but it's all lazy so the extra
707 -- work doesn't matter
708 addErrAt loc msg = do { ctxt <- getErrCtxt
709 ; tidy_env <- tcInitTidyEnv
710 ; err_info <- mkErrInfo tidy_env ctxt
711 ; addLongErrAt loc msg err_info }
712
713 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
714 addErrs msgs = mapM_ add msgs
715 where
716 add (loc,msg) = addErrAt loc msg
717
718 checkErr :: Bool -> MsgDoc -> TcRn ()
719 -- Add the error if the bool is False
720 checkErr ok msg = unless ok (addErr msg)
721
722 warnIf :: Bool -> MsgDoc -> TcRn ()
723 warnIf True msg = addWarn msg
724 warnIf False _ = return ()
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 :: ErrMsg -> TcRn ()
781 reportWarning err
782 = do { let warn = makeIntoWarning 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 warnTc :: Bool -> MsgDoc -> TcM ()
1085 warnTc warn_if_true warn_msg
1086 | warn_if_true = addWarnTc warn_msg
1087 | otherwise = return ()
1088
1089 warnTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1090 warnTcM warn_if_true warn_msg
1091 | warn_if_true = addWarnTcM warn_msg
1092 | otherwise = return ()
1093
1094 addWarnTc :: MsgDoc -> TcM ()
1095 addWarnTc msg = do { env0 <- tcInitTidyEnv
1096 ; addWarnTcM (env0, msg) }
1097
1098 addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
1099 addWarnTcM (env0, msg)
1100 = do { ctxt <- getErrCtxt ;
1101 err_info <- mkErrInfo env0 ctxt ;
1102 add_warn msg err_info }
1103
1104 addWarn :: MsgDoc -> TcRn ()
1105 addWarn msg = add_warn msg Outputable.empty
1106
1107 addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
1108 addWarnAt loc msg = add_warn_at loc msg Outputable.empty
1109
1110 add_warn :: MsgDoc -> MsgDoc -> TcRn ()
1111 add_warn msg extra_info
1112 = do { loc <- getSrcSpanM
1113 ; add_warn_at loc msg extra_info }
1114
1115 add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1116 add_warn_at loc msg extra_info
1117 = do { dflags <- getDynFlags ;
1118 printer <- getPrintUnqualified dflags ;
1119 let { warn = mkLongWarnMsg dflags loc printer
1120 msg extra_info } ;
1121 reportWarning warn }
1122
1123 tcInitTidyEnv :: TcM TidyEnv
1124 tcInitTidyEnv
1125 = do { lcl_env <- getLclEnv
1126 ; return (tcl_tidy lcl_env) }
1127
1128 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1129 -- type. Useful when tidying open types.
1130 tcInitOpenTidyEnv :: TyCoVarSet -> TcM TidyEnv
1131 tcInitOpenTidyEnv tvs
1132 = do { env1 <- tcInitTidyEnv
1133 ; let env2 = tidyFreeTyCoVars env1 tvs
1134 ; return env2 }
1135
1136
1137 {-
1138 -----------------------------------
1139 Other helper functions
1140 -}
1141
1142 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1143 -> [ErrCtxt]
1144 -> TcM ()
1145 add_err_tcm tidy_env err_msg loc ctxt
1146 = do { err_info <- mkErrInfo tidy_env ctxt ;
1147 addLongErrAt loc err_msg err_info }
1148
1149 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1150 -- Tidy the error info, trimming excessive contexts
1151 mkErrInfo env ctxts
1152 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1153 -- = return empty -- just becomes too voluminous
1154 | otherwise
1155 = go 0 env ctxts
1156 where
1157 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1158 go _ _ [] = return empty
1159 go n env ((is_landmark, ctxt) : ctxts)
1160 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1161 = do { (env', msg) <- ctxt env
1162 ; let n' = if is_landmark then n else n+1
1163 ; rest <- go n' env' ctxts
1164 ; return (msg $$ rest) }
1165 | otherwise
1166 = go n env ctxts
1167
1168 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1169 mAX_CONTEXTS = 3
1170
1171 -- debugTc is useful for monadic debugging code
1172
1173 debugTc :: TcM () -> TcM ()
1174 debugTc thing
1175 | debugIsOn = thing
1176 | otherwise = return ()
1177
1178 {-
1179 ************************************************************************
1180 * *
1181 Type constraints
1182 * *
1183 ************************************************************************
1184 -}
1185
1186 newTcEvBinds :: TcM EvBindsVar
1187 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1188 ; uniq <- newUnique
1189 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1190 ; return (EvBindsVar ref uniq) }
1191
1192 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1193 -- Add a binding to the TcEvBinds by side effect
1194 addTcEvBind (EvBindsVar ev_ref u) ev_bind
1195 = do { traceTc "addTcEvBind" $ ppr u $$
1196 ppr ev_bind
1197 ; bnds <- readTcRef ev_ref
1198 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1199
1200 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1201 getTcEvBinds (EvBindsVar ev_ref _)
1202 = do { bnds <- readTcRef ev_ref
1203 ; return (evBindMapBinds bnds) }
1204
1205 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1206 getTcEvBindsMap (EvBindsVar ev_ref _)
1207 = readTcRef ev_ref
1208
1209 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1210 chooseUniqueOccTc fn =
1211 do { env <- getGblEnv
1212 ; let dfun_n_var = tcg_dfun_n env
1213 ; set <- readTcRef dfun_n_var
1214 ; let occ = fn set
1215 ; writeTcRef dfun_n_var (extendOccSet set occ)
1216 ; return occ }
1217
1218 getConstraintVar :: TcM (TcRef WantedConstraints)
1219 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1220
1221 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1222 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1223
1224 emitConstraints :: WantedConstraints -> TcM ()
1225 emitConstraints ct
1226 = do { lie_var <- getConstraintVar ;
1227 updTcRef lie_var (`andWC` ct) }
1228
1229 emitSimple :: Ct -> TcM ()
1230 emitSimple ct
1231 = do { lie_var <- getConstraintVar ;
1232 updTcRef lie_var (`addSimples` unitBag ct) }
1233
1234 emitSimples :: Cts -> TcM ()
1235 emitSimples cts
1236 = do { lie_var <- getConstraintVar ;
1237 updTcRef lie_var (`addSimples` cts) }
1238
1239 emitImplication :: Implication -> TcM ()
1240 emitImplication ct
1241 = do { lie_var <- getConstraintVar ;
1242 updTcRef lie_var (`addImplics` unitBag ct) }
1243
1244 emitImplications :: Bag Implication -> TcM ()
1245 emitImplications ct
1246 = unless (isEmptyBag ct) $
1247 do { lie_var <- getConstraintVar ;
1248 updTcRef lie_var (`addImplics` ct) }
1249
1250 emitInsoluble :: Ct -> TcM ()
1251 emitInsoluble ct
1252 = do { lie_var <- getConstraintVar ;
1253 updTcRef lie_var (`addInsols` unitBag ct) ;
1254 v <- readTcRef lie_var ;
1255 traceTc "emitInsoluble" (ppr v) }
1256
1257 -- | Throw out any constraints emitted by the thing_inside
1258 discardConstraints :: TcM a -> TcM a
1259 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1260
1261 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1262 -- (captureConstraints m) runs m, and returns the type constraints it generates
1263 captureConstraints thing_inside
1264 = do { lie_var <- newTcRef emptyWC ;
1265 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1266 thing_inside ;
1267 lie <- readTcRef lie_var ;
1268 return (res, lie) }
1269
1270 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1271 pushLevelAndCaptureConstraints thing_inside
1272 = do { env <- getLclEnv
1273 ; lie_var <- newTcRef emptyWC
1274 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1275 ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1276 , tcl_lie = lie_var })
1277 thing_inside
1278 ; lie <- readTcRef lie_var
1279 ; return (tclvl', lie, res) }
1280
1281 pushTcLevelM_ :: TcM a -> TcM a
1282 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1283
1284 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1285 pushTcLevelM thing_inside
1286 = do { env <- getLclEnv
1287 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1288 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1289 thing_inside
1290 ; return (res, tclvl') }
1291
1292 getTcLevel :: TcM TcLevel
1293 getTcLevel = do { env <- getLclEnv
1294 ; return (tcl_tclvl env) }
1295
1296 setTcLevel :: TcLevel -> TcM a -> TcM a
1297 setTcLevel tclvl thing_inside
1298 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1299
1300 isTouchableTcM :: TcTyVar -> TcM Bool
1301 isTouchableTcM tv
1302 = do { env <- getLclEnv
1303 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1304
1305 getLclTypeEnv :: TcM TcTypeEnv
1306 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1307
1308 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1309 -- Set the local type envt, but do *not* disturb other fields,
1310 -- notably the lie_var
1311 setLclTypeEnv lcl_env thing_inside
1312 = updLclEnv upd thing_inside
1313 where
1314 upd env = env { tcl_env = tcl_env lcl_env,
1315 tcl_tyvars = tcl_tyvars lcl_env }
1316
1317 traceTcConstraints :: String -> TcM ()
1318 traceTcConstraints msg
1319 = do { lie_var <- getConstraintVar
1320 ; lie <- readTcRef lie_var
1321 ; traceTc (msg ++ ": LIE:") (ppr lie)
1322 }
1323
1324 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1325 emitWildCardHoleConstraints wcs
1326 = do { ctLoc <- getCtLocM HoleOrigin Nothing
1327 ; forM_ wcs $ \(name, tv) -> do {
1328 ; let real_span = case nameSrcSpan name of
1329 RealSrcSpan span -> span
1330 UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1331 (ppr name <+> quotes (ftext str))
1332 -- Wildcards are defined locally, and so have RealSrcSpans
1333 ctLoc' = setCtLocSpan ctLoc real_span
1334 ty = mkTyVarTy tv
1335 can = CHoleCan { cc_ev = CtDerived { ctev_pred = ty
1336 , ctev_loc = ctLoc' }
1337 , cc_occ = occName name
1338 , cc_hole = TypeHole }
1339 ; emitInsoluble can } }
1340
1341 {-
1342 ************************************************************************
1343 * *
1344 Template Haskell context
1345 * *
1346 ************************************************************************
1347 -}
1348
1349 recordThUse :: TcM ()
1350 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1351
1352 recordThSpliceUse :: TcM ()
1353 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1354
1355 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1356 keepAlive name
1357 = do { env <- getGblEnv
1358 ; traceRn (text "keep alive" <+> ppr name)
1359 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1360
1361 getStage :: TcM ThStage
1362 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1363
1364 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1365 getStageAndBindLevel name
1366 = do { env <- getLclEnv;
1367 ; case lookupNameEnv (tcl_th_bndrs env) name of
1368 Nothing -> return Nothing
1369 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1370
1371 setStage :: ThStage -> TcM a -> TcRn a
1372 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1373
1374 {-
1375 ************************************************************************
1376 * *
1377 Safe Haskell context
1378 * *
1379 ************************************************************************
1380 -}
1381
1382 -- | Mark that safe inference has failed
1383 -- See Note [Safe Haskell Overlapping Instances Implementation]
1384 -- although this is used for more than just that failure case.
1385 recordUnsafeInfer :: WarningMessages -> TcM ()
1386 recordUnsafeInfer warns =
1387 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1388
1389 -- | Figure out the final correct safe haskell mode
1390 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1391 finalSafeMode dflags tcg_env = do
1392 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1393 return $ case safeHaskell dflags of
1394 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1395 | otherwise -> Sf_None
1396 s -> s
1397
1398 -- | Switch instances to safe instances if we're in Safe mode.
1399 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1400 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1401 fixSafeInstances _ = map fixSafe
1402 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1403 in inst { is_flag = new_flag }
1404
1405 {-
1406 ************************************************************************
1407 * *
1408 Stuff for the renamer's local env
1409 * *
1410 ************************************************************************
1411 -}
1412
1413 getLocalRdrEnv :: RnM LocalRdrEnv
1414 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1415
1416 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1417 setLocalRdrEnv rdr_env thing_inside
1418 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1419
1420 {-
1421 ************************************************************************
1422 * *
1423 Stuff for interface decls
1424 * *
1425 ************************************************************************
1426 -}
1427
1428 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1429 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
1430 if_loc = loc,
1431 if_tv_env = emptyUFM,
1432 if_id_env = emptyUFM }
1433
1434 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1435 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1436 -- based on 'TcGblEnv'.
1437 initIfaceTcRn :: IfG a -> TcRn a
1438 initIfaceTcRn thing_inside
1439 = do { tcg_env <- getGblEnv
1440 ; let { if_env = IfGblEnv {
1441 if_rec_types = Just (tcg_mod tcg_env, get_type_env)
1442 }
1443 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1444 ; setEnvs (if_env, ()) thing_inside }
1445
1446 initIfaceCheck :: HscEnv -> IfG a -> IO a
1447 -- Used when checking the up-to-date-ness of the old Iface
1448 -- Initialise the environment with no useful info at all
1449 initIfaceCheck hsc_env do_this
1450 = do let rec_types = case hsc_type_env_var hsc_env of
1451 Just (mod,var) -> Just (mod, readTcRef var)
1452 Nothing -> Nothing
1453 gbl_env = IfGblEnv { if_rec_types = rec_types }
1454 initTcRnIf 'i' hsc_env gbl_env () do_this
1455
1456 initIfaceTc :: ModIface
1457 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1458 -- Used when type-checking checking an up-to-date interface file
1459 -- No type envt from the current module, but we do know the module dependencies
1460 initIfaceTc iface do_this
1461 = do { tc_env_var <- newTcRef emptyTypeEnv
1462 ; let { gbl_env = IfGblEnv {
1463 if_rec_types = Just (mod, readTcRef tc_env_var)
1464 } ;
1465 ; if_lenv = mkIfLclEnv mod doc
1466 }
1467 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1468 }
1469 where
1470 mod = mi_module iface
1471 doc = text "The interface for" <+> quotes (ppr mod)
1472
1473 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1474 initIfaceLcl mod loc_doc thing_inside
1475 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1476
1477 getIfModule :: IfL Module
1478 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1479
1480 --------------------
1481 failIfM :: MsgDoc -> IfL a
1482 -- The Iface monad doesn't have a place to accumulate errors, so we
1483 -- just fall over fast if one happens; it "shouldnt happen".
1484 -- We use IfL here so that we can get context info out of the local env
1485 failIfM msg
1486 = do { env <- getLclEnv
1487 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1488 ; dflags <- getDynFlags
1489 ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
1490 ; failM }
1491
1492 --------------------
1493 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1494 -- Run thing_inside in an interleaved thread.
1495 -- It shares everything with the parent thread, so this is DANGEROUS.
1496 --
1497 -- It returns Nothing if the computation fails
1498 --
1499 -- It's used for lazily type-checking interface
1500 -- signatures, which is pretty benign
1501
1502 forkM_maybe doc thing_inside
1503 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1504 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1505 = do { child_us <- newUniqueSupply
1506 ; child_env_us <- newMutVar child_us
1507 -- see Note [Masking exceptions in forkM_maybe]
1508 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1509 do { traceIf (text "Starting fork {" <+> doc)
1510 ; mb_res <- tryM $
1511 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1512 thing_inside
1513 ; case mb_res of
1514 Right r -> do { traceIf (text "} ending fork" <+> doc)
1515 ; return (Just r) }
1516 Left exn -> do {
1517
1518 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1519 -- Otherwise we silently discard errors. Errors can legitimately
1520 -- happen when compiling interface signatures (see tcInterfaceSigs)
1521 whenDOptM Opt_D_dump_if_trace $ do
1522 dflags <- getDynFlags
1523 let msg = hang (text "forkM failed:" <+> doc)
1524 2 (text (show exn))
1525 liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
1526
1527 ; traceIf (text "} ending fork (badly)" <+> doc)
1528 ; return Nothing }
1529 }}
1530
1531 forkM :: SDoc -> IfL a -> IfL a
1532 forkM doc thing_inside
1533 = do { mb_res <- forkM_maybe doc thing_inside
1534 ; return (case mb_res of
1535 Nothing -> pgmError "Cannot continue after interface file error"
1536 -- pprPanic "forkM" doc
1537 Just r -> r) }
1538
1539 {-
1540 Note [Masking exceptions in forkM_maybe]
1541 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1542
1543 When using GHC-as-API it must be possible to interrupt snippets of code
1544 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1545 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1546 subtle problem: runStmt first typechecks the code before running it, and the
1547 exception might interrupt the type checker rather than the code. Moreover, the
1548 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1549 more importantly might be inside an exception handler inside that
1550 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1551 asynchronous exception as a synchronous exception, and the exception will end
1552 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1553 discussion). We don't currently know a general solution to this problem, but
1554 we can use uninterruptibleMask_ to avoid the situation.
1555 -}