TcRnMonad.hs 51.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
{-
(c) The University of Glasgow 2006

Simon Marlow's avatar
Simon Marlow committed
4

5
Functions for working with the typechecker environment (setters, getters...).
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
9
{-# OPTIONS_GHC -fno-warn-orphans #-}
10

11
module TcRnMonad(
Ian Lynagh's avatar
Ian Lynagh committed
12
13
14
        module TcRnMonad,
        module TcRnTypes,
        module IOEnv
15
16
  ) where

17
18
#include "HsVersions.h"

Ian Lynagh's avatar
Ian Lynagh committed
19
20
import TcRnTypes        -- Re-export all
import IOEnv            -- Re-export all
21
import TcEvidence
22

Simon Marlow's avatar
Simon Marlow committed
23
24
25
26
27
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
batterseapower's avatar
batterseapower committed
28
import Type
29

Simon Marlow's avatar
Simon Marlow committed
30
31
32
import TcType
import InstEnv
import FamInstEnv
33
import PrelNames
34

Simon Marlow's avatar
Simon Marlow committed
35
36
37
38
39
40
41
42
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
43
import Outputable
Simon Marlow's avatar
Simon Marlow committed
44
import UniqSupply
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
import Annotations
52
import BasicTypes( TopLevelFlag )
53

54
import Control.Exception
Simon Marlow's avatar
Simon Marlow committed
55
import Data.IORef
56
import qualified Data.Set as Set
57
import Control.Monad
58
59
60
61

#ifdef GHCI
import qualified Data.Map as Map
#endif
62

Austin Seipp's avatar
Austin Seipp committed
63
64
65
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
66
                        initTc
Austin Seipp's avatar
Austin Seipp committed
67
68
69
*                                                                      *
************************************************************************
-}
mnislaih's avatar
mnislaih committed
70

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

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

        dependent_files_var <- newIORef [] ;
Facundo Domínguez's avatar
Facundo Domínguez committed
97
        static_wc_var       <- newIORef emptyWC ;
98
#ifdef GHCI
99
100
101
        th_topdecls_var      <- newIORef [] ;
        th_topnames_var      <- newIORef emptyNameSet ;
        th_modfinalizers_var <- newIORef [] ;
102
        th_state_var         <- newIORef Map.empty ;
103
#endif /* GHCI */
Ian Lynagh's avatar
Ian Lynagh committed
104
        let {
105
106
             dflags = hsc_dflags hsc_env ;

107
108
             maybe_rn_syntax :: forall a. a -> Maybe a ;
             maybe_rn_syntax empty_val
Ian Lynagh's avatar
Ian Lynagh committed
109
110
111
112
                | keep_rn_syntax = Just empty_val
                | otherwise      = Nothing ;

             gbl_env = TcGblEnv {
113
#ifdef GHCI
114
115
116
                tcg_th_topdecls      = th_topdecls_var,
                tcg_th_topnames      = th_topnames_var,
                tcg_th_modfinalizers = th_modfinalizers_var,
117
                tcg_th_state         = th_state_var,
118
119
#endif /* GHCI */

120
121
                tcg_mod            = mod,
                tcg_src            = hsc_src,
122
123
                tcg_sig_of         = getSigOf dflags (moduleName mod),
                tcg_impl_rdr_env   = Nothing,
124
125
126
127
128
129
130
131
                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,
132
                tcg_ann_env        = emptyAnnEnv,
133
                tcg_visible_orphan_mods = mkModuleSet [mod],
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
                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          = [],
Gergő Érdi's avatar
Gergő Érdi committed
157
                tcg_patsyns        = [],
158
159
160
161
162
                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
163
                tcg_safeInfer      = infer_var,
Adam Gundry's avatar
Adam Gundry committed
164
                tcg_dependent_files = dependent_files_var,
Facundo Domínguez's avatar
Facundo Domínguez committed
165
166
                tcg_tc_plugins     = [],
                tcg_static_wc      = static_wc_var
Ian Lynagh's avatar
Ian Lynagh committed
167
168
169
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
170
                tcl_loc        = loc,     -- Should be over-ridden very soon!
Ian Lynagh's avatar
Ian Lynagh committed
171
172
173
                tcl_ctxt       = [],
                tcl_rdr        = emptyLocalRdrEnv,
                tcl_th_ctxt    = topStage,
174
                tcl_th_bndrs   = emptyNameEnv,
Ian Lynagh's avatar
Ian Lynagh committed
175
176
                tcl_arrow_ctxt = NoArrowCtxt,
                tcl_env        = emptyNameEnv,
177
                tcl_bndrs      = [],
178
                tcl_tidy       = emptyTidyEnv,
Ian Lynagh's avatar
Ian Lynagh committed
179
180
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
181
                tcl_tclvl      = topTcLevel
Ian Lynagh's avatar
Ian Lynagh committed
182
183
184
185
186
187
188
189
190
             } ;
        } ;

        -- 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 } ;
191

192
        -- Check for unsolved constraints
Ian Lynagh's avatar
Ian Lynagh committed
193
        lie <- readIORef lie_var ;
194
        if isEmptyWC lie
195
           then return ()
196
           else pprPanic "initTc: unsolved constraints" (ppr lie) ;
197

Ian Lynagh's avatar
Ian Lynagh committed
198
199
        -- Collect any error messages
        msgs <- readIORef errs_var ;
200

201
        let { final_res | errorsFound dflags msgs = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
202
                        | otherwise               = maybe_res } ;
203

Ian Lynagh's avatar
Ian Lynagh committed
204
        return (msgs, final_res)
205
    }
206

207

208
209
210
211
212
initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
-- Initialise the type checker monad for use in GHCi
initTcInteractive hsc_env thing_inside
  = initTc hsc_env HsSrcFile False
           (icInteractiveModule (hsc_IC hsc_env))
213
           (realSrcLocSpan interactive_src_loc)
214
           thing_inside
215
216
  where
    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
217
218

initTcForLookup :: HscEnv -> TcM a -> IO a
219
220
221
-- The thing_inside is just going to look up something
-- in the environment, so we don't need much setup
initTcForLookup hsc_env thing_inside
222
223
  = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
       ; case m of
224
             Nothing -> throwIO $ mkSrcErr $ snd msgs
225
             Just x -> return x }
226

Austin Seipp's avatar
Austin Seipp committed
227
228
229
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
230
                Initialisation
Austin Seipp's avatar
Austin Seipp committed
231
232
233
*                                                                      *
************************************************************************
-}
234

Ian Lynagh's avatar
Ian Lynagh committed
235
236
237
238
239
initTcRnIf :: Char              -- Tag for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
240
initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
241
242
   = do { us     <- mkSplitUniqSupply uniq_tag ;
        ; us_var <- newIORef us ;
243

Ian Lynagh's avatar
Ian Lynagh committed
244
245
246
247
        ; let { env = Env { env_top = hsc_env,
                            env_us  = us_var,
                            env_gbl = gbl_env,
                            env_lcl = lcl_env} }
248

Ian Lynagh's avatar
Ian Lynagh committed
249
250
        ; runIOEnv env thing_inside
        }
251

Austin Seipp's avatar
Austin Seipp committed
252
253
254
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
255
                Simple accessors
Austin Seipp's avatar
Austin Seipp committed
256
257
258
*                                                                      *
************************************************************************
-}
259

260
261
262
discardResult :: TcM a -> TcM ()
discardResult a = a >> return ()

263
getTopEnv :: TcRnIf gbl lcl HscEnv
264
265
getTopEnv = do { env <- getEnv; return (env_top env) }

266
getGblEnv :: TcRnIf gbl lcl gbl
267
268
getGblEnv = do { env <- getEnv; return (env_gbl env) }

269
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
Ian Lynagh's avatar
Ian Lynagh committed
270
271
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
                          env { env_gbl = upd gbl })
272

273
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
274
275
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

276
getLclEnv :: TcRnIf gbl lcl lcl
277
278
getLclEnv = do { env <- getEnv; return (env_lcl env) }

279
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
Ian Lynagh's avatar
Ian Lynagh committed
280
281
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
                          env { env_lcl = upd lcl })
282

283
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
284
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
285

286
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
287
288
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

289
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
290
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
291

Austin Seipp's avatar
Austin Seipp committed
292
-- Command-line flags
293

294
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
295
xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
296

297
298
299
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }

ian@well-typed.com's avatar
ian@well-typed.com committed
300
301
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
302

303
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
304
woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
305

306
307
308
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}} )
309

ian@well-typed.com's avatar
ian@well-typed.com committed
310
311
312
unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                            env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} )
313

314
315
316
317
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}} )

318
-- | Do it flag is true
319
320
321
322
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag thing_inside = do b <- doptM flag
                                 when b thing_inside

ian@well-typed.com's avatar
ian@well-typed.com committed
323
324
325
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag thing_inside = do b <- goptM flag
                                 when b thing_inside
326

ian@well-typed.com's avatar
ian@well-typed.com committed
327
328
329
whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM flag thing_inside = do b <- woptM flag
                                 when b thing_inside
330

ian@well-typed.com's avatar
ian@well-typed.com committed
331
332
333
whenXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag thing_inside = do b <- xoptM flag
                                 when b thing_inside
334

335
336
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
337

338
339
340
withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDoDynamicToo m = do env <- getEnv
                        let dflags = extractDynFlags env
341
                            dflags' = dynamicTooMkDynamicDynFlags dflags
342
343
344
                            env' = replaceDynFlags env dflags'
                        setEnv env' m

345
346
347
348
349
350
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) }

351
352
353
354
355
-- | 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.
356
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
Ian Lynagh's avatar
Ian Lynagh committed
357
          -> TcRnIf gbl lcl a
358
359
360
361
362
363
364
365
366
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.
367
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
Ian Lynagh's avatar
Ian Lynagh committed
368
           -> TcRnIf gbl lcl ()
369
370
371
372
updateEps_ upd_fn = do
  traceIf (text "updating EPS_")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
373
374
375

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
376
377
378

getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
Ian Lynagh's avatar
Ian Lynagh committed
379
                  ; return (eps, hsc_HPT env) }
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
{-
************************************************************************
*                                                                      *
                Arrow scopes
*                                                                      *
************************************************************************
-}

newArrowScope :: TcM a -> TcM a
newArrowScope
  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
  = updLclEnv $ \ env ->
    case tcl_arrow_ctxt env of
      NoArrowCtxt       -> env
      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
                                   , tcl_lie = lie
                                   , tcl_rdr = rdr_env }

Austin Seipp's avatar
Austin Seipp committed
403
404
405
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
406
                Unique supply
Austin Seipp's avatar
Austin Seipp committed
407
408
409
*                                                                      *
************************************************************************
-}
410
411

newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
412
413
newUnique
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
414
415
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
416
417
418
        case takeUniqFromSupply us of { (uniq, us') -> do {
        writeMutVar u_var us' ;
        return $! uniq }}}
Simon Marlow's avatar
Simon Marlow committed
419
420
421
422
423
424
   -- 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.
425
426
427
428

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
429
430
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
431
        case splitUniqSupply us of { (us1,us2) -> do {
Ian Lynagh's avatar
Ian Lynagh committed
432
433
        writeMutVar u_var us1 ;
        return us2 }}}
434

435
436
newLocalName :: Name -> TcM Name
newLocalName name = newName (nameOccName name)
batterseapower's avatar
batterseapower committed
437

batterseapower's avatar
batterseapower committed
438
439
440
441
442
443
newName :: OccName -> TcM Name
newName occ
  = do { uniq <- newUnique
       ; loc  <- getSrcSpanM
       ; return (mkInternalName uniq occ loc) }

444
445
446
447
448
newSysName :: OccName -> TcM Name
newSysName occ
  = do { uniq <- newUnique
       ; return (mkSystemName uniq occ) }

449
450
451
452
453
newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs ty
  = do  { u <- newUnique
        ; return (mkSysLocal fs u ty) }

454
455
456
457
458
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
  = do  { us <- newUniqueSupply
        ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }

batterseapower's avatar
batterseapower committed
459
460
461
instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
462

Austin Seipp's avatar
Austin Seipp committed
463
464
465
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
466
                Debugging
Austin Seipp's avatar
Austin Seipp committed
467
468
469
*                                                                      *
************************************************************************
-}
470

471
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
Ian Lynagh's avatar
Ian Lynagh committed
472
newTcRef = newMutVar
473
474
475
476
477
478
479
480

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 ()
481
482
483
484
485
486
487
488
489
-- Returns ()
updTcRef ref fn = liftIO $ do { old <- readIORef ref
                              ; writeIORef ref (fn old) }

updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
-- Returns previous value
updTcRefX ref fn = liftIO $ do { old <- readIORef ref
                              ; writeIORef ref (fn old)
                              ; return old }
490

Austin Seipp's avatar
Austin Seipp committed
491
492
493
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
494
                Debugging
Austin Seipp's avatar
Austin Seipp committed
495
496
497
*                                                                      *
************************************************************************
-}
498

Ian Lynagh's avatar
Ian Lynagh committed
499
traceTc :: String -> SDoc -> TcRn ()
Simon Peyton Jones's avatar
Simon Peyton Jones committed
500
traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
501

502
-- | Typechecker trace
Simon Peyton Jones's avatar
Simon Peyton Jones committed
503
504
traceTcN :: Int -> SDoc -> TcRn ()
traceTcN level doc
505
506
507
    = do dflags <- getDynFlags
         when (level <= traceLevel dflags && not opt_NoDebugOutput) $
             traceOptTcRn Opt_D_dump_tc_trace doc
508

Simon Peyton Jones's avatar
Simon Peyton Jones committed
509
traceRn :: SDoc -> TcRn ()
510
traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
511

512
513
514
515
516
517
-- | Output a doc if the given 'DumpFlag' is set.
--
-- By default this logs to stdout
-- However, if the `-ddump-to-file` flag is set,
-- then this will dump output to a file
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
518
-- Just a wrapper for 'dumpSDoc'
519
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
520
traceOptTcRn flag doc
521
  = do { dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
522
523
524
525
526
527
528
529
530
531
532
533
534
535
       ; when (dopt flag dflags) (traceTcRn flag doc)
    }

traceTcRn :: DumpFlag -> SDoc -> TcRn ()
-- ^ Unconditionally dump some trace output
--
-- The DumpFlag is used only to set the output filename
-- for --dump-to-file, not to decide whether or not to output
-- That part is done by the caller
traceTcRn flag doc
  = do { real_doc <- prettyDoc doc
       ; dflags   <- getDynFlags
       ; printer  <- getPrintUnqualified dflags
       ; liftIO $ dumpSDoc dflags printer flag "" real_doc  }
536
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
537
    -- Add current location if opt_PprStyle_Debug
538
539
540
541
542
543
544
545
546
547
548
549
    prettyDoc :: SDoc -> TcRn SDoc
    prettyDoc doc = if opt_PprStyle_Debug
       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
       else return doc -- The full location is usually way too much


getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
getPrintUnqualified dflags
  = do { rdr_env <- getGlobalRdrEnv
       ; return $ mkPrintUnqualified dflags rdr_env }

-- | Like logInfoTcRn, but for user consumption
550
551
552
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn doc
  = do { dflags <- getDynFlags
553
       ; printer <- getPrintUnqualified dflags
554
       ; liftIO (printOutputForUser dflags printer doc) }
555

556
-- | Typechecker debug
557
debugDumpTcRn :: SDoc -> TcRn ()
558
debugDumpTcRn doc = unless opt_NoDebugOutput $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
559
                    traceOptTcRn Opt_D_dump_tc doc
560

Austin Seipp's avatar
Austin Seipp committed
561
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
562
563
564
traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
available.  Alas, they behave inconsistently with the other stuff;
e.g. are unaffected by -dump-to-file.
Austin Seipp's avatar
Austin Seipp committed
565
-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
566
567
568
569
570
571
572
573
574
575
576

traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs


traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag doc
  = whenDOptM flag $    -- No RdrEnv available, so qualify everything
    do { dflags <- getDynFlags
       ; liftIO (putMsg dflags doc) }
577

Austin Seipp's avatar
Austin Seipp committed
578
579
580
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
581
                Typechecker global environment
Austin Seipp's avatar
Austin Seipp committed
582
583
584
*                                                                      *
************************************************************************
-}
585

586
587
588
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

589
getIsGHCi :: TcRn Bool
590
591
getIsGHCi = do { mod <- getModule
               ; return (isInteractiveModule mod) }
592

dterei's avatar
dterei committed
593
594
595
getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }

596
597
598
getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }

599
600
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
601

602
getGlobalRdrEnv :: TcRn GlobalRdrEnv
603
604
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

605
606
607
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

608
getImports :: TcRn ImportAvails
609
610
getImports = do { env <- getGblEnv; return (tcg_imports env) }

611
getFixityEnv :: TcRn FixityEnv
612
613
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

614
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
615
extendFixityEnv new_bit
Ian Lynagh's avatar
Ian Lynagh committed
616
617
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
618

619
620
621
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

622
623
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
624
625
626
627
628
629

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
  ref <- fmap tcg_dependent_files getGblEnv
  dep_files <- readTcRef ref
  writeTcRef ref (fs ++ dep_files)
630

Austin Seipp's avatar
Austin Seipp committed
631
632
633
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
634
                Error management
Austin Seipp's avatar
Austin Seipp committed
635
636
637
*                                                                      *
************************************************************************
-}
638

639
getSrcSpanM :: TcRn SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
640
        -- Avoid clash with Name.getSrcLoc
641
getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
642

643
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
644
645
setSrcSpan (RealSrcSpan real_loc) thing_inside
    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
646
647
-- Don't overwrite useful info with useless:
setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
648
649

addLocM :: (a -> TcM b) -> Located a -> TcM b
650
addLocM fn (L loc a) = setSrcSpan loc $ fn a
651
652

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
653
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
654
655
656

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
657
  setSrcSpan loc $ do
658
659
660
661
662
    (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) =
663
  setSrcSpan loc $ do
664
665
    (b,c) <- fn a
    return (b, L loc c)
666

Austin Seipp's avatar
Austin Seipp committed
667
-- Reporting errors
668

669
670
671
672
673
674
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 })

675
addErr :: MsgDoc -> TcRn ()    -- Ignores the context stack
676
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
677

678
failWith :: MsgDoc -> TcRn a
679
680
failWith msg = addErr msg >> failM

681
addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
682
683
684
-- 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
685
686
addErrAt loc msg = do { ctxt <- getErrCtxt
                      ; tidy_env <- tcInitTidyEnv
687
                      ; err_info <- mkErrInfo tidy_env ctxt
Ian Lynagh's avatar
Ian Lynagh committed
688
                      ; addLongErrAt loc msg err_info }
689

690
addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
691
addErrs msgs = mapM_ add msgs
Ian Lynagh's avatar
Ian Lynagh committed
692
693
             where
               add (loc,msg) = addErrAt loc msg
694

695
checkErr :: Bool -> MsgDoc -> TcRn ()
696
-- Add the error if the bool is False
697
checkErr ok msg = unless ok (addErr msg)
698

699
warnIf :: Bool -> MsgDoc -> TcRn ()
700
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
701
warnIf False _   = return ()
702

703
addMessages :: Messages -> TcRn ()
704
705
addMessages (m_warns, m_errs)
  = do { errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
706
707
708
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns `unionBags` m_warns,
                               errs  `unionBags` m_errs) }
709
710
711
712
713

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
714
715
716
717
718
719
720
  = do  { errs_var <- getErrsVar
        ; (old_warns, _) <- readTcRef errs_var ;

        ; result <- thing_inside

        -- Revert warnings to old_warns
        ; (_new_warns, new_errs) <- readTcRef errs_var
Austin Seipp's avatar
Austin Seipp committed
721
        ; writeTcRef errs_var (old_warns, new_errs)
722

Ian Lynagh's avatar
Ian Lynagh committed
723
        ; return result }
724

Austin Seipp's avatar
Austin Seipp committed
725
726
727
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
728
        Shared error message stuff: renamer and typechecker
Austin Seipp's avatar
Austin Seipp committed
729
730
731
*                                                                      *
************************************************************************
-}
732

733
734
mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt loc msg extra
735
736
737
  = do { dflags <- getDynFlags ;
         printer <- getPrintUnqualified dflags ;
         return $ mkLongErrMsg dflags loc printer msg extra }
738

739
740
741
742
743
744
745
746
addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError

reportErrors :: [ErrMsg] -> TcM ()
reportErrors = mapM_ reportError

reportError :: ErrMsg -> TcRn ()
reportError err
747
748
  = do { traceTc "Adding error:" (pprLocErrMsg err) ;
         errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
749
750
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns, errs `snocBag` err) }
751

752
reportWarning :: ErrMsg -> TcRn ()
753
754
755
756
757
758
759
760
761
762
reportWarning err
  = do { let warn = makeIntoWarning err
                    -- 'err' was build by mkLongErrMsg or something like that,
                    -- so it's of error severity.  For a warning we downgrade
                    -- its severity to SevWarning

       ; traceTc "Adding warning:" (pprLocErrMsg warn)
       ; errs_var <- getErrsVar
       ; (warns, errs) <- readTcRef errs_var
       ; writeTcRef errs_var (warns `snocBag` warn, errs) }
763

764
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
765
-- Does try_m, with a debug-trace on failure
Ian Lynagh's avatar
Ian Lynagh committed
766
try_m thing
767
  = do { mb_r <- tryM thing ;
Ian Lynagh's avatar
Ian Lynagh committed
768
769
         case mb_r of
             Left exn -> do { traceTc "tryTc/recoverM recovering from" $
770
771
                                      text (showException exn)
                            ; return mb_r }
Ian Lynagh's avatar
Ian Lynagh committed
772
             Right _  -> return mb_r }
773
774

-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
775
776
777
recoverM :: TcRn r      -- Recovery action; do this if the main one fails
         -> TcRn r      -- Main action: do this first
         -> TcRn r
778
-- Errors in 'thing' are retained
Ian Lynagh's avatar
Ian Lynagh committed
779
recoverM recover thing
780
  = do { mb_res <- try_m thing ;
Ian Lynagh's avatar
Ian Lynagh committed
781
782
783
         case mb_res of
           Left _    -> recover
           Right res -> return res }
784

785
786
787
788
789

-----------------------
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
790
mapAndRecoverM _ []     = return []
791
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
Ian Lynagh's avatar
Ian Lynagh committed
792
793
794
795
796
                             ; rs <- mapAndRecoverM f xs
                             ; return (case mb_r of
                                          Left _  -> rs
                                          Right r -> r:rs) }

797
798
799
800
-- | Succeeds if applying the argument to all members of the lists succeeds,
--   but nevertheless runs it on all arguments, to collect all errors.
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
801

802
-----------------------
803
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
804
-- (tryTc m) executes m, and returns
Ian Lynagh's avatar
Ian Lynagh committed
805
806
--      Just r,  if m succeeds (returning r)
--      Nothing, if m fails
807
808
-- 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
809
810
811
812
813
814
815
816
817
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
818
819
   }

820
821
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
Ian Lynagh's avatar
Ian Lynagh committed
822
823
824
-- 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
825
826
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
Ian Lynagh's avatar
Ian Lynagh committed
827
tryTcErrs thing
828
  = do  { (msgs, res) <- tryTc thing
829
        ; dflags <- getDynFlags
Ian Lynagh's avatar
Ian Lynagh committed
830
831
832
833
834
835
        ; let errs_found = errorsFound dflags msgs
        ; return (msgs, case res of
                          Nothing -> Nothing
                          Just val | errs_found -> Nothing
                                   | otherwise  -> Just val)
        }
836

837
-----------------------
838
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
839
-- Just like tryTcErrs, except that it ensures that the LIE
840
841
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
842
tryTcLIE thing_inside
843
  = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
Ian Lynagh's avatar
Ian Lynagh committed
844
845
846
847
        ; case mb_res of
            Nothing  -> return (msgs, Nothing)
            Just val -> do { emitConstraints lie; return (msgs, Just val) }
        }
848

849
-----------------------
850
tryTcLIE_ :: TcM r -> TcM r -> TcM r
Ian Lynagh's avatar
Ian Lynagh committed
851
852
853
-- (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.
854
tryTcLIE_ recover main
Ian Lynagh's avatar
Ian Lynagh committed
855
856
857
858
859
860
  = 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
        }
861

862
-----------------------
863
864
865
866
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
867
868
--      (it might have recovered internally)
--      If so, it fails too.
869
870
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
Ian Lynagh's avatar
Ian Lynagh committed
871
872
873
874
875
876
  = do  { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of
            Nothing  -> failM
            Just val -> return val
        }
877

878
879
880
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing

881
ifErrsM :: TcRn r -> TcRn r -> TcRn r
882
--      ifErrsM bale_out normal
883
-- does 'bale_out' if there are errors in errors collection
884
-- otherwise does 'normal'
885
886
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
887
        msgs <- readTcRef errs_var ;
888
        dflags <- getDynFlags ;
Ian Lynagh's avatar
Ian Lynagh committed
889
890
891
892
        if errorsFound dflags msgs then
           bale_out
        else
           normal }
893

894
failIfErrsM :: TcRn ()
895
896
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
897
898

#ifdef GHCI
899
checkTH :: a -> String -> TcRn ()
900
901
checkTH _ _ = return () -- OK
#else
902
checkTH :: Outputable a => a -> String -> TcRn ()
903
904
905
906
907
checkTH e what = failTH e what  -- Raise an error in a stage-1 compiler
#endif

failTH :: Outputable a => a -> String -> TcRn x
failTH e what  -- Raise an error in a stage-1 compiler
908
909
910
911
  = failWithTc (vcat [ hang (char 'A' <+> text what
                             <+> ptext (sLit "requires GHC with interpreter support:"))
                          2 (ppr e)
                     , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
912

Austin Seipp's avatar
Austin Seipp committed
913
914
915
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
916
        Context management for the type checker
Austin Seipp's avatar
Austin Seipp committed
917
918
919
*                                                                      *
************************************************************************
-}
920

921
getErrCtxt :: TcM [ErrCtxt]
922
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
923

924
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
925
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
926

927
addErrCtxt :: MsgDoc -> TcM a -> TcM a
928
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
929

930
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
931
932
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)

933
addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
934
addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
935

936
-- Helper function for the above
937
updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
Ian Lynagh's avatar
Ian Lynagh committed
938
939
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
                           env { tcl_ctxt = upd ctxt })
940

941
popErrCtxt :: TcM a -> TcM a
Ian Lynagh's avatar
Ian Lynagh committed
942