TcRnMonad.lhs 44.3 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
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) ;
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
             } ;
             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,
150
                tcl_tidy       = emptyTidyEnv,
Ian Lynagh's avatar
Ian Lynagh committed
151 152
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
153
                tcl_meta       = meta_var,
Ian Lynagh's avatar
Ian Lynagh committed
154 155 156 157 158 159 160 161 162 163
                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 } ;
164

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

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

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

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

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

initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
189 190 191

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

260

261 262 263
Command-line flags

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

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

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

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

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

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

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

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

294
ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
295
ifXOptM flag thing_inside = do { b <- xoptM flag ;
Ian Lynagh's avatar
Ian Lynagh committed
296
                                if b then thing_inside else return () }
297

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

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

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

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

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

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

\begin{code}
347 348 349
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
350
newMetaUnique
351 352 353 354 355 356
 = do { env <- getLclEnv
      ; let meta_var = tcl_meta env
      ; uniq <- readMutVar meta_var
      ; writeMutVar meta_var (incrUnique uniq)
      ; return uniq }

357
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
358 359
newUnique
 = do { env <- getEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
360 361
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
362 363 364
        case takeUniqFromSupply us of { (uniq, us') -> do {
        writeMutVar u_var us' ;
        return $! uniq }}}
Simon Marlow's avatar
Simon Marlow committed
365 366 367 368 369 370
   -- 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.
371 372 373 374

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

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

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

batterseapower's avatar
batterseapower committed
391 392 393 394 395 396
newName :: OccName -> TcM Name
newName occ
  = do { uniq <- newUnique
       ; loc  <- getSrcSpanM
       ; return (mkInternalName uniq occ loc) }

batterseapower's avatar
batterseapower committed
397 398 399
instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
400 401
\end{code}

402 403

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
404 405 406
%*                                                                      *
                Debugging
%*                                                                      *
407 408
%************************************************************************

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

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
424 425 426
%*                                                                      *
                Debugging
%*                                                                      *
427 428 429
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
430
traceTc :: String -> SDoc -> TcRn ()
431 432
traceTc = traceTcN 1

Ian Lynagh's avatar
Ian Lynagh committed
433
traceTcN :: Int -> String -> SDoc -> TcRn ()
434
traceTcN level herald doc
Ian Lynagh's avatar
Ian Lynagh committed
435 436 437
    = do dflags <- getDynFlags
         when (level <= traceLevel dflags) $
             traceOptTcRn Opt_D_dump_tc_trace $ hang (text herald) 2 doc
438 439

traceRn, traceSplice :: SDoc -> TcRn ()
440 441
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
442

Ian Lynagh's avatar
Ian Lynagh committed
443
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
444 445
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
446

447

448
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
449
traceOptIf flag doc = ifDOptM flag $
450 451
                          do dflags <- getDynFlags
                             liftIO (printInfoForUser dflags alwaysQualify doc)
452

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

dumpTcRn :: SDoc -> TcRn ()
Ian Lynagh's avatar
Ian Lynagh committed
464
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
465
                  ; dflags <- getDynFlags
466
                  ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
467 468 469 470

debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
                  | otherwise         = dumpTcRn doc
471 472

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
473
dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc)
474 475 476 477
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
478 479 480
%*                                                                      *
                Typechecker global environment
%*                                                                      *
481
%************************************************************************
482

483 484
\begin{code}
getModule :: TcRn Module
485 486
getModule = do { env <- getGblEnv; return (tcg_mod env) }

487 488 489
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

490 491 492
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }

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

496 497 498
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

499
getGlobalRdrEnv :: TcRn GlobalRdrEnv
500 501
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

502 503 504
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

505
getImports :: TcRn ImportAvails
506 507
getImports = do { env <- getGblEnv; return (tcg_imports env) }

508
getFixityEnv :: TcRn FixityEnv
509 510
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

511
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
512
extendFixityEnv new_bit
Ian Lynagh's avatar
Ian Lynagh committed
513 514
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
515

516 517 518
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

519 520
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
521 522 523 524 525 526

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

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
530 531 532
%*                                                                      *
                Error management
%*                                                                      *
533 534 535
%************************************************************************

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

540
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
Ian Lynagh's avatar
Ian Lynagh committed
541 542 543 544
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
545 546

addLocM :: (a -> TcM b) -> Located a -> TcM b
547
addLocM fn (L loc a) = setSrcSpan loc $ fn a
548 549

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
550
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
551 552 553

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
554
  setSrcSpan loc $ do
555 556 557 558 559
    (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) =
560
  setSrcSpan loc $ do
561 562
    (b,c) <- fn a
    return (b, L loc c)
563
\end{code}
564

565
Reporting errors
566

567 568 569 570 571 572 573
\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 })

574
addErr :: MsgDoc -> TcRn ()    -- Ignores the context stack
575
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
576

577
failWith :: MsgDoc -> TcRn a
578 579
failWith msg = addErr msg >> failM

580
addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
581 582 583
-- 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
584 585
addErrAt loc msg = do { ctxt <- getErrCtxt
                      ; tidy_env <- tcInitTidyEnv
586
                      ; err_info <- mkErrInfo tidy_env ctxt
Ian Lynagh's avatar
Ian Lynagh committed
587
                      ; addLongErrAt loc msg err_info }
588

589
addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
590
addErrs msgs = mapM_ add msgs
Ian Lynagh's avatar
Ian Lynagh committed
591 592
             where
               add (loc,msg) = addErrAt loc msg
593

594
checkErr :: Bool -> MsgDoc -> TcRn ()
595
-- Add the error if the bool is False
596
checkErr ok msg = unless ok (addErr msg)
597

598
warnIf :: Bool -> MsgDoc -> TcRn ()
599
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
600
warnIf False _   = return ()
601

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

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


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

\begin{code}
633 634 635
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
636
         rdr_env <- getGlobalRdrEnv ;
637
         dflags <- getDynFlags ;
Ian Lynagh's avatar
Ian Lynagh committed
638
         return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
639

640 641 642 643 644 645 646 647 648
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
649 650
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns, errs `snocBag` err) }
651

652 653 654 655 656 657
reportWarning :: ErrMsg -> TcRn ()
reportWarning warn
  = do { errs_var <- getErrsVar ;
         (warns, errs) <- readTcRef errs_var ;
         writeTcRef errs_var (warns `snocBag` warn, errs) }

658 659
dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
660
  = do { dflags <- getDynFlags
661 662 663 664
       ; when (dopt Opt_D_dump_deriv dflags) $ do
       { rdr_env <- getGlobalRdrEnv
       ; let unqual = mkPrintUnqualified dflags rdr_env
       ; liftIO (putMsgWith dflags unqual doc) } }
665 666 667
\end{code}


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

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

690 691 692 693 694

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

702

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

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

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

750
-----------------------
751
tryTcLIE_ :: TcM r -> TcM r -> TcM r
Ian Lynagh's avatar
Ian Lynagh committed
752 753 754
-- (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.
755
tryTcLIE_ recover main
Ian Lynagh's avatar
Ian Lynagh committed
756 757 758 759 760 761
  = 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
        }
762

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

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

792
failIfErrsM :: TcRn ()
793 794 795 796 797 798
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
799 800 801
%*                                                                      *
        Context management for the type checker
%*                                                                      *
802 803 804
%************************************************************************

\begin{code}
805
getErrCtxt :: TcM [ErrCtxt]
806
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
807

808
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
809
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
810

811
addErrCtxt :: MsgDoc -> TcM a -> TcM a
812
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
813

814
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
815 816
addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)

817
addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
818
addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
819

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

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

828 829
getCtLoc :: orig -> TcM (CtLoc orig)
getCtLoc origin
830
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
Ian Lynagh's avatar
Ian Lynagh committed
831
         return (CtLoc origin loc (tcl_ctxt env)) }
832

833 834
setCtLoc :: CtLoc orig -> TcM a -> TcM a
setCtLoc (CtLoc _ src_loc ctxt) thing_inside
835
  = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
836 837
\end{code}

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

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

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

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

-- 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 }
869 870 871 872 873
\end{code}

The failWith functions add an error message and cause failure

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

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

882