TcRnMonad.lhs 43.7 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
2
3
4
%
% (c) The University of Glasgow 2006
%

5
6
Functions for working with the typechecker environment (setters, getters...).

7
\begin{code}
8
module TcRnMonad(
Ian Lynagh's avatar
Ian Lynagh committed
9
10
11
        module TcRnMonad,
        module TcRnTypes,
        module IOEnv
12
13
  ) where

14
15
#include "HsVersions.h"

Ian Lynagh's avatar
Ian Lynagh committed
16
17
import TcRnTypes        -- Re-export all
import IOEnv            -- Re-export all
18
import TcEvidence
19

Simon Marlow's avatar
Simon Marlow committed
20
21
22
23
24
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
batterseapower's avatar
batterseapower committed
25
import Type
26
27
import Kind ( isSuperKind )

Simon Marlow's avatar
Simon Marlow committed
28
29
30
import TcType
import InstEnv
import FamInstEnv
31
import PrelNames
32

Simon Marlow's avatar
Simon Marlow committed
33
34
35
36
37
38
39
40
41
import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
42
import Outputable
Simon Marlow's avatar
Simon Marlow committed
43
44
import UniqSupply
import Unique
45
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
46
47
48
49
import DynFlags
import StaticFlags
import FastString
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
50
import Util
51

Simon Marlow's avatar
Simon Marlow committed
52
53
import System.IO
import Data.IORef
54
import qualified Data.Set as Set
55
import Control.Monad
56
57
58
59
60
\end{code}



%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
61
62
63
%*                                                                      *
                        initTc
%*                                                                      *
64
65
%************************************************************************

66
\begin{code}
mnislaih's avatar
mnislaih committed
67

68
-- | Setup the initial typechecking environment
69
initTc :: HscEnv
70
       -> HscSource
Ian Lynagh's avatar
Ian Lynagh committed
71
72
       -> Bool          -- True <=> retain renamed syntax trees
       -> Module
73
       -> TcM r
74
       -> IO (Messages, Maybe r)
Ian Lynagh's avatar
Ian Lynagh committed
75
76
                -- Nothing => error thrown by the thing inside
                -- (error messages should have been printed already)
77

78
initTc hsc_env hsc_src keep_rn_syntax mod do_this
79
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
80
        meta_var     <- newIORef initTyVarUnique ;
Ian Lynagh's avatar
Ian Lynagh committed
81
        tvs_var      <- newIORef emptyVarSet ;
82
        keep_var     <- newIORef emptyNameSet ;
83
        used_rdr_var <- newIORef Set.empty ;
84
85
        th_var       <- newIORef False ;
        th_splice_var<- newIORef False ;
86
        infer_var    <- newIORef True ;
87
        lie_var      <- newIORef emptyWC ;
Ian Lynagh's avatar
Ian Lynagh committed
88
89
        dfun_n_var   <- newIORef emptyOccSet ;
        type_env_var <- case hsc_type_env_var hsc_env of {
90
91
                           Just (_mod, te_var) -> return te_var ;
                           Nothing             -> newIORef emptyNameEnv } ;
GregWeber's avatar
GregWeber committed
92
93

        dependent_files_var <- newIORef [] ;
Ian Lynagh's avatar
Ian Lynagh committed
94
        let {
95
96
             maybe_rn_syntax :: forall a. a -> Maybe a ;
             maybe_rn_syntax empty_val
Ian Lynagh's avatar
Ian Lynagh committed
97
98
99
100
                | keep_rn_syntax = Just empty_val
                | otherwise      = Nothing ;

             gbl_env = TcGblEnv {
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
                tcg_mod            = mod,
                tcg_src            = hsc_src,
                tcg_rdr_env        = emptyGlobalRdrEnv,
                tcg_fix_env        = emptyNameEnv,
                tcg_field_env      = RecFields emptyNameEnv emptyNameSet,
                tcg_default        = Nothing,
                tcg_type_env       = emptyNameEnv,
                tcg_type_env_var   = type_env_var,
                tcg_inst_env       = emptyInstEnv,
                tcg_fam_inst_env   = emptyFamInstEnv,
                tcg_th_used        = th_var,
                tcg_th_splice_used = th_splice_var,
                tcg_exports        = [],
                tcg_imports        = emptyImportAvails,
                tcg_used_rdrnames  = used_rdr_var,
                tcg_dus            = emptyDUs,

                tcg_rn_imports     = [],
                tcg_rn_exports     = maybe_rn_syntax [],
                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,

                tcg_binds          = emptyLHsBinds,
                tcg_imp_specs      = [],
                tcg_sigs           = emptyNameSet,
                tcg_ev_binds       = emptyBag,
                tcg_warns          = NoWarnings,
                tcg_anns           = [],
                tcg_tcs            = [],
                tcg_insts          = [],
                tcg_fam_insts      = [],
                tcg_rules          = [],
                tcg_fords          = [],
                tcg_vects          = [],
                tcg_dfun_n         = dfun_n_var,
                tcg_keep           = keep_var,
                tcg_doc_hdr        = Nothing,
                tcg_hpc            = False,
                tcg_main           = Nothing,
GregWeber's avatar
GregWeber committed
139
140
                tcg_safeInfer      = infer_var,
                tcg_dependent_files = dependent_files_var
Ian Lynagh's avatar
Ian Lynagh committed
141
142
143
144
145
146
147
148
149
150
151
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
                tcl_loc        = mkGeneralSrcSpan (fsLit "Top level"),
                tcl_ctxt       = [],
                tcl_rdr        = emptyLocalRdrEnv,
                tcl_th_ctxt    = topStage,
                tcl_arrow_ctxt = NoArrowCtxt,
                tcl_env        = emptyNameEnv,
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
152
                tcl_meta       = meta_var,
Ian Lynagh's avatar
Ian Lynagh committed
153
154
155
156
157
158
159
160
161
162
                tcl_untch      = initTyVarUnique
             } ;
        } ;

        -- OK, here's the business end!
        maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
                     do { r <- tryM do_this
                        ; case r of
                          Right res -> return (Just res)
                          Left _    -> return Nothing } ;
163

164
        -- Check for unsolved constraints
Ian Lynagh's avatar
Ian Lynagh committed
165
        lie <- readIORef lie_var ;
166
        if isEmptyWC lie
167
           then return ()
Ian Lynagh's avatar
Ian Lynagh committed
168
           else pprPanic "initTc: unsolved constraints"
169
170
                         (pprWantedsWithLocs lie) ;

Ian Lynagh's avatar
Ian Lynagh committed
171
172
        -- Collect any error messages
        msgs <- readIORef errs_var ;
173

Ian Lynagh's avatar
Ian Lynagh committed
174
175
176
        let { dflags = hsc_dflags hsc_env
            ; final_res | errorsFound dflags msgs = Nothing
                        | otherwise               = maybe_res } ;
177

Ian Lynagh's avatar
Ian Lynagh committed
178
        return (msgs, final_res)
179
    }
180

Ian Lynagh's avatar
Ian Lynagh committed
181
initTcPrintErrors       -- Used from the interactive loop only
182
       :: HscEnv
Ian Lynagh's avatar
Ian Lynagh committed
183
       -> Module
184
       -> TcM r
185
       -> IO (Messages, Maybe r)
186
187

initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
188
189
\end{code}

190
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
191
192
193
%*                                                                      *
                Initialisation
%*                                                                      *
194
195
196
197
%************************************************************************


\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
198
199
200
201
202
initTcRnIf :: Char              -- Tag for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
203
initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
204
205
   = do { us     <- mkSplitUniqSupply uniq_tag ;
        ; us_var <- newIORef us ;
206

Ian Lynagh's avatar
Ian Lynagh committed
207
208
209
210
        ; let { env = Env { env_top = hsc_env,
                            env_us  = us_var,
                            env_gbl = gbl_env,
                            env_lcl = lcl_env} }
211

Ian Lynagh's avatar
Ian Lynagh committed
212
213
        ; runIOEnv env thing_inside
        }
214
215
\end{code}

216
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
217
218
219
%*                                                                      *
                Simple accessors
%*                                                                      *
220
221
222
%************************************************************************

\begin{code}
223
getTopEnv :: TcRnIf gbl lcl HscEnv
224
225
getTopEnv = do { env <- getEnv; return (env_top env) }

226
getGblEnv :: TcRnIf gbl lcl gbl
227
228
getGblEnv = do { env <- getEnv; return (env_gbl env) }

229
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
Ian Lynagh's avatar
Ian Lynagh committed
230
231
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
                          env { env_gbl = upd gbl })
232

233
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
234
235
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

236
getLclEnv :: TcRnIf gbl lcl lcl
237
238
getLclEnv = do { env <- getEnv; return (env_lcl env) }

239
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
Ian Lynagh's avatar
Ian Lynagh committed
240
241
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
                          env { env_lcl = upd lcl })
242

243
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
244
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
245

246
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
247
248
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

249
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
250
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
251
252
\end{code}

253

254
255
256
Command-line flags

\begin{code}
257
258
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
259

260
261
262
263
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) }

doptM :: DynFlag -> TcRnIf gbl lcl Bool
264
265
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }

266
267
268
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) }

269
270
271
setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                          env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
272

273
274
275
unsetDOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetDOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                            env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
276

277
278
279
280
unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                            env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )

281
-- | Do it flag is true
282
ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
283
ifDOptM flag thing_inside = do { b <- doptM flag ;
Ian Lynagh's avatar
Ian Lynagh committed
284
                                if b then thing_inside else return () }
285

286
ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
287
ifWOptM flag thing_inside = do { b <- woptM flag ;
Ian Lynagh's avatar
Ian Lynagh committed
288
                                if b then thing_inside else return () }
289

290
ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
291
ifXOptM flag thing_inside = do { b <- xoptM flag ;
Ian Lynagh's avatar
Ian Lynagh committed
292
                                if b then thing_inside else return () }
293

294
295
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
296
297
298
\end{code}

\begin{code}
299
300
301
302
303
304
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }

305
306
307
308
309
-- | Update the external package state.  Returns the second result of the
-- modifier function.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
310
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
Ian Lynagh's avatar
Ian Lynagh committed
311
          -> TcRnIf gbl lcl a
312
313
314
315
316
317
318
319
320
updateEps upd_fn = do
  traceIf (text "updating EPS")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var upd_fn

-- | Update the external package state.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
321
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
Ian Lynagh's avatar
Ian Lynagh committed
322
           -> TcRnIf gbl lcl ()
323
324
325
326
updateEps_ upd_fn = do
  traceIf (text "updating EPS_")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
327
328
329

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
330
331
332

getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
Ian Lynagh's avatar
Ian Lynagh committed
333
                  ; return (eps, hsc_HPT env) }
334
\end{code}
335

336
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
337
338
339
%*                                                                      *
                Unique supply
%*                                                                      *
340
341
342
%************************************************************************

\begin{code}
343
344
345
newMetaUnique :: TcM Unique
-- The uniques for TcMetaTyVars are allocated specially
-- in guaranteed linear order, starting at zero for each module
Ian Lynagh's avatar
Ian Lynagh committed
346
newMetaUnique
347
348
349
350
351
352
 = do { env <- getLclEnv
      ; let meta_var = tcl_meta env
      ; uniq <- readMutVar meta_var
      ; writeMutVar meta_var (incrUnique uniq)
      ; return uniq }

353
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
354
355
newUnique
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
356
357
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
358
359
360
        case takeUniqFromSupply us of { (uniq, us') -> do {
        writeMutVar u_var us' ;
        return $! uniq }}}
Simon Marlow's avatar
Simon Marlow committed
361
362
363
364
365
366
   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
   -- a chain of unevaluated supplies behind.
   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
   -- throw away one half of the new split supply.  This is safe because this
   -- is the only place we use that unique.  Using the other half of the split
   -- supply is safer, but slower.
367
368
369
370

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
371
372
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
373
        case splitUniqSupply us of { (us1,us2) -> do {
Ian Lynagh's avatar
Ian Lynagh committed
374
375
        writeMutVar u_var us1 ;
        return us2 }}}
376
377

newLocalName :: Name -> TcRnIf gbl lcl Name
Ian Lynagh's avatar
Ian Lynagh committed
378
379
380
newLocalName name       -- Make a clone
  = do  { uniq <- newUnique
        ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
381
382
383

newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
Ian Lynagh's avatar
Ian Lynagh committed
384
385
  = do  { us <- newUniqueSupply
        ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
batterseapower's avatar
batterseapower committed
386

batterseapower's avatar
batterseapower committed
387
388
389
390
391
392
newName :: OccName -> TcM Name
newName occ
  = do { uniq <- newUnique
       ; loc  <- getSrcSpanM
       ; return (mkInternalName uniq occ loc) }

batterseapower's avatar
batterseapower committed
393
394
395
instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
396
397
\end{code}

398
399

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
400
401
402
%*                                                                      *
                Debugging
%*                                                                      *
403
404
%************************************************************************

405
\begin{code}
406
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
Ian Lynagh's avatar
Ian Lynagh committed
407
newTcRef = newMutVar
408
409
410
411
412
413
414
415
416
417
418
419

readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef = readMutVar

writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = writeMutVar

updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef = updMutVar
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
420
421
422
%*                                                                      *
                Debugging
%*                                                                      *
423
424
425
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
426
traceTc :: String -> SDoc -> TcRn ()
427
428
traceTc = traceTcN 1

Ian Lynagh's avatar
Ian Lynagh committed
429
traceTcN :: Int -> String -> SDoc -> TcRn ()
430
431
432
433
434
435
traceTcN level herald doc
  | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $
                              hang (text herald) 2 doc
  | otherwise               = return ()

traceRn, traceSplice :: SDoc -> TcRn ()
436
437
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
438

Ian Lynagh's avatar
Ian Lynagh committed
439
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
440
441
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
442

443

444
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
445
traceOptIf flag doc = ifDOptM flag $
Ian Lynagh's avatar
Ian Lynagh committed
446
                      liftIO (printForUser stderr alwaysQualify doc)
447

448
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
449
-- Output the message, with current location if opt_PprStyle_Debug
450
traceOptTcRn flag doc = ifDOptM flag $ do
Ian Lynagh's avatar
Ian Lynagh committed
451
452
                        { loc  <- getSrcSpanM
                        ; let real_doc
453
                                | opt_PprStyle_Debug = mkLocMessage loc doc
Ian Lynagh's avatar
Ian Lynagh committed
454
455
456
                                | otherwise = doc   -- The full location is
                                                    -- usually way too much
                        ; dumpTcRn real_doc }
457
458

dumpTcRn :: SDoc -> TcRn ()
Ian Lynagh's avatar
Ian Lynagh committed
459
460
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
                  ; dflags <- getDOpts
461
                  ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
462
463
464
465

debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
                  | otherwise         = dumpTcRn doc
466
467

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
468
dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc)
469
470
471
472
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
473
474
475
%*                                                                      *
                Typechecker global environment
%*                                                                      *
476
%************************************************************************
477

478
479
\begin{code}
getModule :: TcRn Module
480
481
getModule = do { env <- getGblEnv; return (tcg_mod env) }

482
483
484
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

485
486
487
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }

488
489
490
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

491
getGlobalRdrEnv :: TcRn GlobalRdrEnv
492
493
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

494
495
496
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

497
getImports :: TcRn ImportAvails
498
499
getImports = do { env <- getGblEnv; return (tcg_imports env) }

500
getFixityEnv :: TcRn FixityEnv
501
502
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

503
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
504
extendFixityEnv new_bit
Ian Lynagh's avatar
Ian Lynagh committed
505
506
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
507

508
509
510
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

511
512
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
513
514
515
516
517
518

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
  ref <- fmap tcg_dependent_files getGblEnv
  dep_files <- readTcRef ref
  writeTcRef ref (fs ++ dep_files)
519
520
521
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
522
523
524
%*                                                                      *
                Error management
%*                                                                      *
525
526
527
%************************************************************************

\begin{code}
528
getSrcSpanM :: TcRn SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
529
        -- Avoid clash with Name.getSrcLoc
530
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
531

532
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
Ian Lynagh's avatar
Ian Lynagh committed
533
534
535
536
setSrcSpan loc@(RealSrcSpan _) thing_inside
    = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
-- Don't overwrite useful info with useless:
setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
537
538

addLocM :: (a -> TcM b) -> Located a -> TcM b
539
addLocM fn (L loc a) = setSrcSpan loc $ fn a
540
541

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
542
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
543
544
545

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
546
  setSrcSpan loc $ do
547
548
549
550
551
    (b,c) <- fn a
    return (L loc b, c)

wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
552
  setSrcSpan loc $ do
553
554
    (b,c) <- fn a
    return (b, L loc c)
555
\end{code}
556

557
Reporting errors
558

559
560
561
562
563
564
565
\begin{code}
getErrsVar :: TcRn (TcRef Messages)
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }

setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })

Ian Lynagh's avatar
Ian Lynagh committed
566
addErr :: Message -> TcRn ()    -- Ignores the context stack
567
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
568

569
570
571
failWith :: Message -> TcRn a
failWith msg = addErr msg >> failM

572
addErrAt :: SrcSpan -> Message -> TcRn ()
573
574
575
-- addErrAt is mainly (exclusively?) used by the renamer, where
-- tidying is not an issue, but it's all lazy so the extra
-- work doesn't matter
Ian Lynagh's avatar
Ian Lynagh committed
576
577
addErrAt loc msg = do { ctxt <- getErrCtxt
                      ; tidy_env <- tcInitTidyEnv
578
                      ; err_info <- mkErrInfo tidy_env ctxt
Ian Lynagh's avatar
Ian Lynagh committed
579
                      ; addLongErrAt loc msg err_info }
580

581
addErrs :: [(SrcSpan,Message)] -> TcRn ()
582
addErrs msgs = mapM_ add msgs
Ian Lynagh's avatar
Ian Lynagh committed
583
584
             where
               add (loc,msg) = addErrAt loc msg
585

586
addWarn :: Message -> TcRn ()
587
addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
588

589
addWarnAt :: SrcSpan -> Message -> TcRn ()
590
addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
591

592
checkErr :: Bool -> Message -> TcRn ()
593
-- Add the error if the bool is False
594
checkErr ok msg = unless ok (addErr msg)
595

596
warnIf :: Bool -> Message -> TcRn ()
597
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
598
warnIf False _   = return ()
599

600
addMessages :: Messages -> TcRn ()
601
602
addMessages (m_warns, m_errs)
  = do { errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
603
604
605
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns `unionBags` m_warns,
                               errs  `unionBags` m_errs) }
606
607
608
609
610

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
611
612
613
614
615
616
617
618
619
  = do  { errs_var <- getErrsVar
        ; (old_warns, _) <- readTcRef errs_var ;

        ; result <- thing_inside

        -- Revert warnings to old_warns
        ; (_new_warns, new_errs) <- readTcRef errs_var
        ; writeTcRef errs_var (old_warns, new_errs) 

Ian Lynagh's avatar
Ian Lynagh committed
620
        ; return result }
621
622
623
\end{code}


624
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
625
626
627
%*                                                                      *
        Shared error message stuff: renamer and typechecker
%*                                                                      *
628
629
630
631
%************************************************************************

\begin{code}
addReport :: Message -> Message -> TcRn ()
632
addReport msg extra_info = do { traceTc "addr" msg; loc <- getSrcSpanM; addReportAt loc msg extra_info }
633
634
635
636

addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
addReportAt loc msg extra_info
  = do { errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
637
         rdr_env <- getGlobalRdrEnv ;
638
         dflags <- getDOpts ;
Ian Lynagh's avatar
Ian Lynagh committed
639
640
641
642
         let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
                                    msg extra_info } ;
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns `snocBag` warn, errs) }
643
644
645

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
Ian Lynagh's avatar
Ian Lynagh committed
646
647
648
  = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ;
         errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
649
         dflags <- getDOpts ;
Ian Lynagh's avatar
Ian Lynagh committed
650
651
652
         let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns, errs `snocBag` err) }
653
654
655
656
657
658
659
660

dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
  = do { dflags <- getDOpts
       ; when (dopt Opt_D_dump_deriv dflags) $ do
       { rdr_env <- getGlobalRdrEnv
       ; let unqual = mkPrintUnqualified dflags rdr_env
       ; liftIO (putMsgWith dflags unqual doc) } }
661
662
663
\end{code}


664
\begin{code}
665
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
666
-- Does try_m, with a debug-trace on failure
Ian Lynagh's avatar
Ian Lynagh committed
667
try_m thing
668
  = do { mb_r <- tryM thing ;
Ian Lynagh's avatar
Ian Lynagh committed
669
670
         case mb_r of
             Left exn -> do { traceTc "tryTc/recoverM recovering from" $
671
672
                                      text (showException exn)
                            ; return mb_r }
Ian Lynagh's avatar
Ian Lynagh committed
673
             Right _  -> return mb_r }
674
675

-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
676
677
678
recoverM :: TcRn r      -- Recovery action; do this if the main one fails
         -> TcRn r      -- Main action: do this first
         -> TcRn r
679
-- Errors in 'thing' are retained
Ian Lynagh's avatar
Ian Lynagh committed
680
recoverM recover thing
681
  = do { mb_res <- try_m thing ;
Ian Lynagh's avatar
Ian Lynagh committed
682
683
684
         case mb_res of
           Left _    -> recover
           Right res -> return res }
685

686
687
688
689
690

-----------------------
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
-- Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
Ian Lynagh's avatar
Ian Lynagh committed
691
mapAndRecoverM _ []     = return []
692
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
Ian Lynagh's avatar
Ian Lynagh committed
693
694
695
696
697
                             ; rs <- mapAndRecoverM f xs
                             ; return (case mb_r of
                                          Left _  -> rs
                                          Right r -> r:rs) }

698

699
-----------------------
700
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
701
-- (tryTc m) executes m, and returns
Ian Lynagh's avatar
Ian Lynagh committed
702
703
--      Just r,  if m succeeds (returning r)
--      Nothing, if m fails
704
705
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
Ian Lynagh's avatar
Ian Lynagh committed
706
707
708
709
710
711
712
713
714
tryTc m
 = do { errs_var <- newTcRef emptyMessages ;
        res  <- try_m (setErrsVar errs_var m) ;
        msgs <- readTcRef errs_var ;
        return (msgs, case res of
                            Left _  -> Nothing
                            Right val -> Just val)
        -- The exception is always the IOEnv built-in
        -- in exception; see IOEnv.failM
715
716
   }

717
718
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
Ian Lynagh's avatar
Ian Lynagh committed
719
720
721
-- Run the thing, returning
--      Just r,  if m succceeds with no error messages
--      Nothing, if m fails, or if it succeeds but has error messages
722
723
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
Ian Lynagh's avatar
Ian Lynagh committed
724
tryTcErrs thing
725
  = do  { (msgs, res) <- tryTc thing
Ian Lynagh's avatar
Ian Lynagh committed
726
727
728
729
730
731
732
        ; dflags <- getDOpts
        ; let errs_found = errorsFound dflags msgs
        ; return (msgs, case res of
                          Nothing -> Nothing
                          Just val | errs_found -> Nothing
                                   | otherwise  -> Just val)
        }
733

734
-----------------------
735
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
736
-- Just like tryTcErrs, except that it ensures that the LIE
737
738
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
739
tryTcLIE thing_inside
740
  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
Ian Lynagh's avatar
Ian Lynagh committed
741
742
743
744
        ; case mb_res of
            Nothing  -> return (msgs, Nothing)
            Just val -> do { emitConstraints lie; return (msgs, Just val) }
        }
745

746
-----------------------
747
tryTcLIE_ :: TcM r -> TcM r -> TcM r
Ian Lynagh's avatar
Ian Lynagh committed
748
749
750
-- (tryTcLIE_ r m) tries m;
--      if m succeeds with no error messages, it's the answer
--      otherwise tryTcLIE_ drops everything from m and tries r instead.
751
tryTcLIE_ recover main
Ian Lynagh's avatar
Ian Lynagh committed
752
753
754
755
756
757
  = do  { (msgs, mb_res) <- tryTcLIE main
        ; case mb_res of
             Just val -> do { addMessages msgs  -- There might be warnings
                             ; return val }
             Nothing  -> recover                -- Discard all msgs
        }
758

759
-----------------------
760
761
762
763
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
Ian Lynagh's avatar
Ian Lynagh committed
764
765
--      (it might have recovered internally)
--      If so, it fails too.
766
767
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
Ian Lynagh's avatar
Ian Lynagh committed
768
769
770
771
772
773
  = do  { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of
            Nothing  -> failM
            Just val -> return val
        }
774

775
ifErrsM :: TcRn r -> TcRn r -> TcRn r
Ian Lynagh's avatar
Ian Lynagh committed
776
--      ifErrsM bale_out main
777
778
779
780
-- does 'bale_out' if there are errors in errors collection
-- otherwise does 'main'
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
781
782
783
784
785
786
        msgs <- readTcRef errs_var ;
        dflags <- getDOpts ;
        if errorsFound dflags msgs then
           bale_out
        else
           normal }
787

788
failIfErrsM :: TcRn ()
789
790
791
792
793
794
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
795
796
797
%*                                                                      *
        Context management for the type checker
%*                                                                      *
798
799
800
%************************************************************************

\begin{code}
801
getErrCtxt :: TcM [ErrCtxt]
802
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
803

804
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
805
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
806

807
addErrCtxt :: Message -> TcM a -> TcM a
808
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
809

810
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
811
812
813
814
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)

addLandmarkErrCtxt :: Message -> TcM a -> TcM a
addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
815

816
-- Helper function for the above
817
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
Ian Lynagh's avatar
Ian Lynagh committed
818
819
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
                           env { tcl_ctxt = upd ctxt })
820

821
popErrCtxt :: TcM a -> TcM a
Ian Lynagh's avatar
Ian Lynagh committed
822
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
823

824
825
getCtLoc :: orig -> TcM (CtLoc orig)
getCtLoc origin
826
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
827
         return (CtLoc origin loc (tcl_ctxt env)) }
828

829
830
setCtLoc :: CtLoc orig -> TcM a -> TcM a
setCtLoc (CtLoc _ src_loc ctxt) thing_inside
831
  = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
832
833
\end{code}

834
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
835
836
837
%*                                                                      *
             Error message generation (type checker)
%*                                                                      *
838
839
%************************************************************************

840
    The addErrTc functions add an error message, but do not cause failure.
841
842
843
844
845
    The 'M' variants pass a TidyEnv that has already been used to
    tidy up the message; we then use it to tidy the context messages

\begin{code}
addErrTc :: Message -> TcM ()
846
addErrTc err_msg = do { env0 <- tcInitTidyEnv
Ian Lynagh's avatar
Ian Lynagh committed
847
                      ; addErrTcM (env0, err_msg) }
848
849

addErrsTc :: [Message] -> TcM ()
850
addErrsTc err_msgs = mapM_ addErrTc err_msgs
851
852
853
854

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
Ian Lynagh's avatar
Ian Lynagh committed
855
856
         loc  <- getSrcSpanM ;
         add_err_tcm tidy_env err_msg loc ctxt }
857
858
859
860
861
\end{code}

The failWith functions add an error message and cause failure

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
862
863
failWithTc :: Message -> TcM a               -- Add an error message and fail
failWithTc err_msg
864
865
866
867
868
869
  = addErrTc err_msg >> failM

failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
failWithTcM local_and_msg
  = addErrTcM local_and_msg >> failM

Ian Lynagh's avatar
Ian Lynagh committed
870
checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
Ian Lynagh's avatar
Ian Lynagh committed
871
checkTc True  _   = return ()
872
873
874
checkTc False err = failWithTc err
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
875
        Warnings have no 'M' variant, nor failure
876
877
878

\begin{code}
addWarnTc :: Message -> TcM ()
Ian Lynagh's avatar
Ian Lynagh committed
879
880
addWarnTc msg = do { env0 <- tcInitTidyEnv
                   ; addWarnTcM (env0, msg) }
881
882
883

addWarnTcM :: (TidyEnv, Message) -> TcM ()
addWarnTcM (env0, msg)
884
 = do { ctxt <- getErrCtxt ;
Ian Lynagh's avatar
Ian Lynagh committed
885
886
        err_info <- mkErrInfo env0 ctxt ;
        addReport (ptext (sLit "Warning:") <+> msg) err_info }
887
888
889
890

warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
  | warn_if_true = addWarnTc warn_msg
Ian Lynagh's avatar
Ian Lynagh committed
891
  | otherwise    = return ()
892
893
\end{code}

894
-----------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
895
         Tidying
896
897
898
899
900
901
902
903

We initialise the "tidy-env", used for tidying types before printing,
by building a reverse map from the in-scope type variables to the
OccName that the programmer originally used for them

\begin{code}
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
Ian Lynagh's avatar
Ian Lynagh committed
904
905
906
907
908
  = do  { lcl_env <- getLclEnv
        ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
                          | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
                          , tcIsTyVarTy ty ]
        ; return (foldl add emptyTidyEnv nm_tv_prs) }
909
910
  where
    add (env,subst) (name, tyvar)
Ian Lynagh's avatar
Ian Lynagh committed
911
912
913
914
915
        = case tidyOccName env (nameOccName name) of
            (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
                where
                  tyvar' = setTyVarName tyvar name'
                  name'  = tidyNameOcc name occ'
916
917
918
\end{code}

-----------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
919
        Other helper functions
920
921

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
922
add_err_tcm :: TidyEnv -> Message -> SrcSpan
923
            -> [ErrCtxt]
Ian Lynagh's avatar
Ian Lynagh committed
924
            -> TcM ()
925
add_err_tcm tidy_env err_msg loc ctxt
926
 = do { err_info <- mkErrInfo tidy_env ctxt ;
Ian Lynagh's avatar
Ian Lynagh committed
927
        addLongErrAt loc err_msg err_info }
928
929
930
931

mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo env ctxts
Ian Lynagh's avatar
Ian Lynagh committed
932
933
 | opt_PprStyle_Debug     -- In -dppr-debug style the output
 = return empty           -- just becomes too voluminous
934
 | otherwise
935
936
937
938
939
 = go 0 env ctxts
 where
   go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
   go _ _   [] = return empty
   go n env ((is_landmark, ctxt) : ctxts)
Ian Lynagh's avatar
Ian Lynagh committed
940
     | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
941
     = do { (env', msg) <- ctxt env
Ian Lynagh's avatar
Ian Lynagh committed
942
          ; let n' = if is_landmark then n else n+1
943
          ; rest <- go n' env' ctxts
Ian Lynagh's avatar
Ian Lynagh committed
944
          ; return (msg $$ rest) }
945
946
947
     | otherwise
     = go n env ctxts

Ian Lynagh's avatar
Ian Lynagh committed
948
mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
949
mAX_CONTEXTS = 3
950
951
\end{code}

952
debugTc is useful for monadic debugging code
953
954
955

\begin{code}
debugTc :: TcM () -> TcM ()
Ian Lynagh's avatar
Ian Lynagh committed
956
957
958
debugTc thing
 | debugIsOn = thing
 | otherwise = return ()
959
960
\end{code}

961
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
962
963
964
%*                                                                      *
             Type constraints
%*                                                                      *
965
966
967
%************************************************************************

\begin{code}
968
969
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
Ian Lynagh's avatar
Ian Lynagh committed
970
971
                  ; uniq <- newUnique
                  ; return (EvBindsVar ref uniq) }
972
973
974

addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
-- Add a binding to the TcEvBinds by side effect
batterseapower's avatar
batterseapower committed
975
addTcEvBind (EvBindsVar ev_ref _) var t
976
  = do { bnds <- readTcRef ev_ref
batterseapower's avatar
batterseapower committed
977
       ; writeTcRef ev_ref (extendEvBinds bnds var t) }
978

979
980
981
982
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
  do { env <- getGblEnv
     ; let dfun_n_var = tcg_dfun_n env
983
     ; set <- readTcRef dfun_n_var
984
     ; let occ = fn set
985
986
     ; writeTcRef dfun_n_var (extendOccSet set occ)
     ; return occ }
987

988
989
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
990

991
992
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
993

994
995
996
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
  = do { lie_var <- getConstraintVar ;
997
         updTcRef lie_var (`andWC` ct) }
998

999
1000
emitFlat :: WantedEvVar -> TcM ()
emitFlat ct
1001
  = do { lie_var <- getConstraintVar ;
1002
1003
1004
1005
1006
1007
1008
         updTcRef lie_var (`addFlats` unitBag ct) }

emitFlats :: Bag WantedEvVar -> TcM ()
emitFlats ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addFlats` ct) }

1009
1010
1011
1012
1013
1014
1015
emitWantedCts :: Cts -> TcM () 
-- Precondition: all wanted
emitWantedCts = mapBagM_ emit_wanted_ct
  where emit_wanted_ct ct 
          | v <- cc_id ct 
          , Wanted loc <- cc_flavor ct 
          = emitFlat (EvVarX v loc)
dimitris's avatar
dimitris committed
1016
          | otherwise = panic "emitWantedCts: can't emit non-wanted!"
1017

1018
1019
1020
1021
1022
1023
1024
1025
1026
emitImplication :: Implication -> TcM ()
emitImplication ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addImplics` unitBag ct) }

emitImplications :: Bag Implication -> TcM ()
emitImplications ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addImplics` ct) }
1027

1028
1029
1030
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
1031
  = do { lie_var <- newTcRef emptyWC ;
Ian Lynagh's avatar
Ian Lynagh committed
1032
         res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1033
1034
1035
                          thing_inside ;
         lie <- readTcRef lie_var ;
         return (res, lie) }
1036

1037
1038
1039
1040
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
  = do { env <- getLclEnv
       ; low_meta <- readTcRef (tcl_meta env)
Ian Lynagh's avatar
Ian Lynagh committed
1041
1042
       ; res <- setLclEnv (env { tcl_untch = low_meta })
                thing_inside
1043
1044
       ; high_meta <- readTcRef (tcl_meta env)
       ; return (res, TouchableRange low_meta high_meta) }
1045
1046

isUntouchable :: TcTyVar -> TcM Bool
1047
1048
1049
1050
1051
1052
1053
isUntouchable tv
    -- Kind variables are always touchable
  | isSuperKind (tyVarKind tv) 
  = return False
  | otherwise 
  = do { env <- getLclEnv
       ; return (varUnique tv < tcl_untch env) }
1054

1055
getLclTypeEnv :: TcM TcTypeEnv
1056
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1057
1058
1059
1060
1061
1062
1063
1064

setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
-- Set the local type envt, but do *not* disturb other fields,
-- notably the lie_var
setLclTypeEnv lcl_env thing_inside
  = updLclEnv upd thing_inside
  where