TcRnMonad.lhs 44.4 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
{-# OPTIONS_GHC -fno-warn-orphans #-}
9
module TcRnMonad(
Ian Lynagh's avatar
Ian Lynagh committed
10 11 12
        module TcRnMonad,
        module TcRnTypes,
        module IOEnv
13 14
  ) where

15 16
#include "HsVersions.h"

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

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

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

Simon Marlow's avatar
Simon Marlow committed
34 35 36 37 38 39 40 41 42
import Var
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
import DynFlags
47
import Maybes
Simon Marlow's avatar
Simon Marlow committed
48 49 50
import StaticFlags
import FastString
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
51
import Util
52

Simon Marlow's avatar
Simon Marlow committed
53
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) ;
Ian Lynagh's avatar
Ian Lynagh committed
80
        tvs_var      <- newIORef emptyVarSet ;
81
        keep_var     <- newIORef emptyNameSet ;
82
        used_rdr_var <- newIORef Set.empty ;
83 84
        th_var       <- newIORef False ;
        th_splice_var<- newIORef False ;
85
        infer_var    <- newIORef True ;
86
        lie_var      <- newIORef emptyWC ;
Ian Lynagh's avatar
Ian Lynagh committed
87 88
        dfun_n_var   <- newIORef emptyOccSet ;
        type_env_var <- case hsc_type_env_var hsc_env of {
89 90
                           Just (_mod, te_var) -> return te_var ;
                           Nothing             -> newIORef emptyNameEnv } ;
GregWeber's avatar
GregWeber committed
91 92

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

             gbl_env = TcGblEnv {
100 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
                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
138 139
                tcg_safeInfer      = infer_var,
                tcg_dependent_files = dependent_files_var
Ian Lynagh's avatar
Ian Lynagh committed
140 141 142 143 144 145 146 147 148
             } ;
             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,
149
                tcl_bndrs      = [],
150
                tcl_tidy       = emptyTidyEnv,
Ian Lynagh's avatar
Ian Lynagh committed
151 152
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
153
                tcl_untch      = noUntouchables
Ian Lynagh's avatar
Ian Lynagh committed
154 155 156 157 158 159 160 161 162
             } ;
        } ;

        -- 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 190

initTcForLookup :: HscEnv -> TcM a -> IO a
initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
191 192
\end{code}

193
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
194 195 196
%*                                                                      *
                Initialisation
%*                                                                      *
197 198 199 200
%************************************************************************


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

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

Ian Lynagh's avatar
Ian Lynagh committed
215 216
        ; runIOEnv env thing_inside
        }
217 218
\end{code}

219
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
220 221 222
%*                                                                      *
                Simple accessors
%*                                                                      *
223 224 225
%************************************************************************

\begin{code}
226 227 228
discardResult :: TcM a -> TcM ()
discardResult a = a >> return ()

229
getTopEnv :: TcRnIf gbl lcl HscEnv
230 231
getTopEnv = do { env <- getEnv; return (env_top env) }

232
getGblEnv :: TcRnIf gbl lcl gbl
233 234
getGblEnv = do { env <- getEnv; return (env_gbl env) }

235
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
Ian Lynagh's avatar
Ian Lynagh committed
236 237
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
                          env { env_gbl = upd gbl })
238

239
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
240 241
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

242
getLclEnv :: TcRnIf gbl lcl lcl
243 244
getLclEnv = do { env <- getEnv; return (env_lcl env) }

245
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
Ian Lynagh's avatar
Ian Lynagh committed
246 247
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
                          env { env_lcl = upd lcl })
248

249
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
250
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
251

252
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
253 254
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

255
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
256
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
257 258
\end{code}

259

260 261 262
Command-line flags

\begin{code}
263
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
264
xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
265 266

doptM :: DynFlag -> TcRnIf gbl lcl Bool
267
doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
268

269
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
270
woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
271

272 273 274
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}} )
275

276 277 278
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}} )
279

280 281 282 283
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}} )

284
-- | Do it flag is true
285
ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
286 287
ifDOptM flag thing_inside = do b <- doptM flag
                               when b thing_inside
288

289
ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
290 291
ifWOptM flag thing_inside = do b <- woptM flag
                               when b thing_inside
292

293
ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
294 295
ifXOptM flag thing_inside = do b <- xoptM flag
                               when b thing_inside
296

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

\begin{code}
302 303 304 305 306 307
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) }

308 309 310 311 312
-- | 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.
313
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
Ian Lynagh's avatar
Ian Lynagh committed
314
          -> TcRnIf gbl lcl a
315 316 317 318 319 320 321 322 323
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.
324
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
Ian Lynagh's avatar
Ian Lynagh committed
325
           -> TcRnIf gbl lcl ()
326 327 328 329
updateEps_ upd_fn = do
  traceIf (text "updating EPS_")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
330 331 332

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
333 334 335

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

339
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
340 341 342
%*                                                                      *
                Unique supply
%*                                                                      *
343 344 345 346
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
347 348
newUnique
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
349 350
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
351 352 353
        case takeUniqFromSupply us of { (uniq, us') -> do {
        writeMutVar u_var us' ;
        return $! uniq }}}
Simon Marlow's avatar
Simon Marlow committed
354 355 356 357 358 359
   -- 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.
360 361 362 363

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
364 365
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
366
        case splitUniqSupply us of { (us1,us2) -> do {
Ian Lynagh's avatar
Ian Lynagh committed
367 368
        writeMutVar u_var us1 ;
        return us2 }}}
369

370 371
newLocalName :: Name -> TcM Name
newLocalName name = newName (nameOccName name)
batterseapower's avatar
batterseapower committed
372

batterseapower's avatar
batterseapower committed
373 374 375 376 377 378
newName :: OccName -> TcM Name
newName occ
  = do { uniq <- newUnique
       ; loc  <- getSrcSpanM
       ; return (mkInternalName uniq occ loc) }

379 380 381 382 383
newSysName :: OccName -> TcM Name
newSysName occ
  = do { uniq <- newUnique
       ; return (mkSystemName uniq occ) }

384 385 386 387 388
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
389 390 391
instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
392 393
\end{code}

394 395

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
396 397 398
%*                                                                      *
                Debugging
%*                                                                      *
399 400
%************************************************************************

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

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
416 417 418
%*                                                                      *
                Debugging
%*                                                                      *
419 420 421
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
422
traceTc :: String -> SDoc -> TcRn ()
423 424
traceTc = traceTcN 1

Ian Lynagh's avatar
Ian Lynagh committed
425
traceTcN :: Int -> String -> SDoc -> TcRn ()
426
traceTcN level herald doc
Ian Lynagh's avatar
Ian Lynagh committed
427 428 429
    = do dflags <- getDynFlags
         when (level <= traceLevel dflags) $
             traceOptTcRn Opt_D_dump_tc_trace $ hang (text herald) 2 doc
430 431

traceRn, traceSplice :: SDoc -> TcRn ()
432 433
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
434

Ian Lynagh's avatar
Ian Lynagh committed
435
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
436 437
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
438

439

440
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
441
traceOptIf flag doc = ifDOptM flag $
442 443
                          do dflags <- getDynFlags
                             liftIO (printInfoForUser dflags alwaysQualify doc)
444

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

dumpTcRn :: SDoc -> TcRn ()
Ian Lynagh's avatar
Ian Lynagh committed
456
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
457
                  ; dflags <- getDynFlags
458
                  ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
459 460 461 462

debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
                  | otherwise         = dumpTcRn doc
463 464

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
465
dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc)
466 467 468 469
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
470 471 472
%*                                                                      *
                Typechecker global environment
%*                                                                      *
473
%************************************************************************
474

475 476
\begin{code}
getModule :: TcRn Module
477 478
getModule = do { env <- getGblEnv; return (tcg_mod env) }

479 480 481
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

482 483 484
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }

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

488 489 490
getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }

491 492 493
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

494
getGlobalRdrEnv :: TcRn GlobalRdrEnv
495 496
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

497 498 499
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

500
getImports :: TcRn ImportAvails
501 502
getImports = do { env <- getGblEnv; return (tcg_imports env) }

503
getFixityEnv :: TcRn FixityEnv
504 505
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

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

511 512 513
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

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

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

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
525 526 527
%*                                                                      *
                Error management
%*                                                                      *
528 529 530
%************************************************************************

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

535
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
Ian Lynagh's avatar
Ian Lynagh committed
536 537 538 539
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
540 541

addLocM :: (a -> TcM b) -> Located a -> TcM b
542
addLocM fn (L loc a) = setSrcSpan loc $ fn a
543 544

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
545
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
546 547 548

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
549
  setSrcSpan loc $ do
550 551 552 553 554
    (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) =
555
  setSrcSpan loc $ do
556 557
    (b,c) <- fn a
    return (b, L loc c)
558
\end{code}
559

560
Reporting errors
561

562 563 564 565 566 567 568
\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 })

569
addErr :: MsgDoc -> TcRn ()    -- Ignores the context stack
570
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
571

572
failWith :: MsgDoc -> TcRn a
573 574
failWith msg = addErr msg >> failM

575
addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
576 577 578
-- 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
579 580
addErrAt loc msg = do { ctxt <- getErrCtxt
                      ; tidy_env <- tcInitTidyEnv
581
                      ; err_info <- mkErrInfo tidy_env ctxt
Ian Lynagh's avatar
Ian Lynagh committed
582
                      ; addLongErrAt loc msg err_info }
583

584
addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
585
addErrs msgs = mapM_ add msgs
Ian Lynagh's avatar
Ian Lynagh committed
586 587
             where
               add (loc,msg) = addErrAt loc msg
588

589
checkErr :: Bool -> MsgDoc -> TcRn ()
590
-- Add the error if the bool is False
591
checkErr ok msg = unless ok (addErr msg)
592

593
warnIf :: Bool -> MsgDoc -> TcRn ()
594
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
595
warnIf False _   = return ()
596

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

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
608 609 610 611 612 613 614 615 616
  = 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
617
        ; return result }
618 619 620
\end{code}


621
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
622 623 624
%*                                                                      *
        Shared error message stuff: renamer and typechecker
%*                                                                      *
625 626 627
%************************************************************************

\begin{code}
628 629 630
mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt loc msg extra
  = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ;
Ian Lynagh's avatar
Ian Lynagh committed
631
         rdr_env <- getGlobalRdrEnv ;
632
         dflags <- getDynFlags ;
Ian Lynagh's avatar
Ian Lynagh committed
633
         return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
634

635 636 637 638 639 640 641 642 643
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
  = do { errs_var <- getErrsVar ;
Ian Lynagh's avatar
Ian Lynagh committed
644 645
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns, errs `snocBag` err) }
646

647 648 649 650 651 652
reportWarning :: ErrMsg -> TcRn ()
reportWarning warn
  = do { errs_var <- getErrsVar ;
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns `snocBag` warn, errs) }

653 654
dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
655
  = do { dflags <- getDynFlags
656 657 658 659
       ; when (dopt Opt_D_dump_deriv dflags) $ do
       { rdr_env <- getGlobalRdrEnv
       ; let unqual = mkPrintUnqualified dflags rdr_env
       ; liftIO (putMsgWith dflags unqual doc) } }
660 661 662
\end{code}


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

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

685 686 687 688 689

-----------------------
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
690
mapAndRecoverM _ []     = return []
691
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
Ian Lynagh's avatar
Ian Lynagh committed
692 693 694 695 696
                             ; rs <- mapAndRecoverM f xs
                             ; return (case mb_r of
                                          Left _  -> rs
                                          Right r -> r:rs) }

697

698
-----------------------
699
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
700
-- (tryTc m) executes m, and returns
Ian Lynagh's avatar
Ian Lynagh committed
701 702
--      Just r,  if m succeeds (returning r)
--      Nothing, if m fails
703 704
-- 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
705 706 707 708 709 710 711 712 713
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
714 715
   }

716 717
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
Ian Lynagh's avatar
Ian Lynagh committed
718 719 720
-- 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
721 722
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
Ian Lynagh's avatar
Ian Lynagh committed
723
tryTcErrs thing
724
  = do  { (msgs, res) <- tryTc thing
725
        ; dflags <- getDynFlags
Ian Lynagh's avatar
Ian Lynagh committed
726 727 728 729 730 731
        ; let errs_found = errorsFound dflags msgs
        ; return (msgs, case res of
                          Nothing -> Nothing
                          Just val | errs_found -> Nothing
                                   | otherwise  -> Just val)
        }
732

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

745
-----------------------
746
tryTcLIE_ :: TcM r -> TcM r -> TcM r
Ian Lynagh's avatar
Ian Lynagh committed
747 748 749
-- (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.
750
tryTcLIE_ recover main
Ian Lynagh's avatar
Ian Lynagh committed
751 752 753 754 755 756
  = 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
        }
757

758
-----------------------
759 760 761 762
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
763 764
--      (it might have recovered internally)
--      If so, it fails too.
765 766
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
Ian Lynagh's avatar
Ian Lynagh committed
767 768 769 770 771 772
  = do  { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of
            Nothing  -> failM
            Just val -> return val
        }
773

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

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


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

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

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

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

809
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
810 811
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)

812
addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
813
addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
814

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

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

823
getCtLoc :: CtOrigin -> TcM CtLoc
824
getCtLoc origin
825 826
  = do { env <- getLclEnv 
       ; return (CtLoc { ctl_origin = origin, ctl_env =  env, ctl_depth = 0 }) }
827

828
setCtLoc :: CtLoc -> TcM a -> TcM a
829
-- Set the SrcSpan and error context from the CtLoc
830
setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
831 832 833 834
  = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
                           , tcl_bndrs = tcl_bndrs lcl
                           , tcl_ctxt = tcl_ctxt lcl }) 
              thing_inside
835 836
\end{code}

837
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
838 839 840
%*                                                                      *
             Error message generation (type checker)
%*                                                                      *
841 842
%************************************************************************

843
    The addErrTc functions add an error message, but do not cause failure.
844 845 846 847
    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}
848
addErrTc :: MsgDoc -> TcM ()
849
addErrTc err_msg = do { env0 <- tcInitTidyEnv
Ian Lynagh's avatar
Ian Lynagh committed
850
                      ; addErrTcM (env0, err_msg) }
851

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

855
addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
856 857
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
Ian Lynagh's avatar
Ian Lynagh committed
858 859
         loc  <- getSrcSpanM ;
         add_err_tcm tidy_env err_msg loc ctxt }
860 861 862 863 864 865 866 867

-- Return the error message, instead of reporting it straight away
mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
mkErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
         loc  <- getSrcSpanM ;
         err_info <- mkErrInfo tidy_env ctxt ;
         mkLongErrAt loc err_msg err_info }
868 869 870 871 872
\end{code}

The failWith functions add an error message and cause failure

\begin{code}
873
failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
Ian Lynagh's avatar
Ian Lynagh committed
874
failWithTc err_msg
875 876
  = addErrTc err_msg >> failM

877
failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail
878 879 880
failWithTcM local_and_msg
  = addErrTcM local_and_msg >> failM

881
checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
Ian Lynagh's avatar
Ian Lynagh committed
882
checkTc True  _   = return ()
883 884 885
checkTc False err = failWithTc err
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
886
        Warnings have no 'M' variant, nor failure
887 888

\begin{code}
889 890 891 892 893 894
warnTc :: Bool -> MsgDoc -> TcM ()
warnTc warn_if_true warn_msg
  | warn_if_true = addWarnTc warn_msg
  | otherwise    = return ()

addWarnTc :: MsgDoc -> TcM ()
Ian Lynagh's avatar
Ian Lynagh committed
895 896
addWarnTc msg = do { env0 <- tcInitTidyEnv
                   ; addWarnTcM (env0, msg) }
897

898
addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
899
addWarnTcM (env0, msg)
900
 = do { ctxt <- getErrCtxt ;
Ian Lynagh's avatar
Ian Lynagh committed
901
        err_info <- mkErrInfo env0 ctxt ;
902
        add_warn msg err_info }
903