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