ghc/compiler/typecheck/TcRnMonad.lhs

   1 \begin{code}
   2 module TcRnMonad(
   3         module TcRnMonad,
   4         module TcRnTypes
   5   ) where
   6
   7 #include "HsVersions.h"
   8
   9 import HsSyn            ( MonoBinds(..) )
  10 import HscTypes         ( HscEnv(..), PersistentCompilerState(..),
  11                           emptyFixityEnv, emptyGlobalRdrEnv, TyThing,
  12                           ExternalPackageState(..), HomePackageTable,
  13                           ModDetails(..), HomeModInfo(..), Deprecations(..),
  14                           GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv,
  15                           GhciMode, lookupType, unQualInScope )
  16 import TcRnTypes
  17 import Module           ( Module, moduleName, unitModuleEnv, foldModuleEnv )
  18 import Name             ( Name, isInternalName )
  19 import Type             ( Type )
  20 import NameEnv          ( extendNameEnvList )
  21 import InstEnv          ( InstEnv, extendInstEnv )
  22 import TysWiredIn       ( integerTy, doubleTy )
  23
  24 import VarSet           ( emptyVarSet )
  25 import VarEnv           ( TidyEnv, emptyTidyEnv )
  26 import RdrName          ( emptyRdrEnv )
  27 import ErrUtils         ( Message, Messages, emptyMessages, errorsFound,
  28                           addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings )
  29 import SrcLoc           ( SrcLoc, noSrcLoc )
  30 import NameEnv          ( emptyNameEnv )
  31 import Bag              ( emptyBag )
  32 import Outputable
  33 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
  34 import Unique           ( Unique )
  35 import CmdLineOpts      ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug )
  36 import BasicTypes       ( FixitySig )
  37 import Bag              ( snocBag, unionBags )
  38
  39 import Maybe            ( isJust )
  40 import IO               ( stderr )
  41 import DATA_IOREF       ( newIORef, readIORef )
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46         Standard combinators, but specialised for this monad
  47                         (for efficiency)
  48 %*                                                                      *
  49 6%************************************************************************
  50
  51 \begin{code}
  52 mappM         :: (a -> TcRn m b) -> [a] -> TcRn m [b]
  53 mappM_        :: (a -> TcRn m b) -> [a] -> TcRn m ()
  54         -- Funny names to avoid clash with Prelude
  55 sequenceM     :: [TcRn m a] -> TcRn m [a]
  56 foldlM        :: (a -> b -> TcRn m a)  -> a -> [b] -> TcRn m a
  57 mapAndUnzipM  :: (a -> TcRn m (b,c))   -> [a] -> TcRn m ([b],[c])
  58 mapAndUnzip3M :: (a -> TcRn m (b,c,d)) -> [a] -> TcRn m ([b],[c],[d])
  59 checkM        :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is False
  60 ifM           :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is True
  61
  62 mappM f []     = return []
  63 mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
  64
  65 mappM_ f []     = return ()
  66 mappM_ f (x:xs) = f x >> mappM_ f xs
  67
  68 sequenceM [] = return []
  69 sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) }
  70
  71 foldlM k z [] = return z
  72 foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs }
  73
  74 mapAndUnzipM f []     = return ([],[])
  75 mapAndUnzipM f (x:xs) = do { (r,s) <- f x;
  76                              (rs,ss) <- mapAndUnzipM f xs;
  77                              return (r:rs, s:ss) }
  78
  79 mapAndUnzip3M f []     = return ([],[], [])
  80 mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x;
  81                               (rs,ss,ts) <- mapAndUnzip3M f xs;
  82                               return (r:rs, s:ss, t:ts) }
  83
  84 checkM True  err = return ()
  85 checkM False err = err
  86
  87 ifM True  do_it = do_it
  88 ifM False do_it = return ()
  89 \end{code}
  90
  91
  92 %************************************************************************
  93 %*                                                                      *
  94                         initTc
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 initTc :: HscEnv -> PersistentCompilerState
 100        -> Module
 101        -> TcM r
 102        -> IO (PersistentCompilerState, Maybe r)
 103                 -- Nothing => error thrown by the thing inside
 104                 -- (error messages should have been printed already)
 105
 106 initTc  (HscEnv { hsc_mode   = ghci_mode,
 107                   hsc_HPT    = hpt,
 108                   hsc_dflags = dflags })
 109         pcs mod do_this
 110  = do { us       <- mkSplitUniqSupply 'a' ;
 111         us_var   <- newIORef us ;
 112         errs_var <- newIORef (emptyBag, emptyBag) ;
 113         tvs_var  <- newIORef emptyVarSet ;
 114         usg_var  <- newIORef emptyUsages ;
 115         nc_var   <- newIORef (pcs_nc pcs) ;
 116         eps_var  <- newIORef eps ;
 117
 118         let {
 119              env = Env { env_top = top_env,
 120                          env_gbl = gbl_env,
 121                          env_lcl = lcl_env,
 122                          env_loc = noSrcLoc } ;
 123
 124              top_env = TopEnv {
 125                 top_mode   = ghci_mode,
 126                 top_dflags = dflags,
 127                 top_eps    = eps_var,
 128                 top_hpt    = hpt,
 129                 top_nc     = nc_var,
 130                 top_us     = us_var,
 131                 top_errs   = errs_var } ;
 132
 133              gbl_env = TcGblEnv {
 134                 tcg_mod      = mod,
 135                 tcg_usages   = usg_var,
 136                 tcg_rdr_env  = emptyGlobalRdrEnv,
 137                 tcg_fix_env  = emptyFixityEnv,
 138                 tcg_default  = defaultDefaultTys,
 139                 tcg_type_env = emptyNameEnv,
 140                 tcg_ist      = mkImpTypeEnv eps hpt,
 141                 tcg_inst_env = mkImpInstEnv dflags eps hpt,
 142                 tcg_exports  = [],
 143                 tcg_imports  = init_imports,
 144                 tcg_binds    = EmptyMonoBinds,
 145                 tcg_deprecs  = NoDeprecs,
 146                 tcg_insts    = [],
 147                 tcg_rules    = [],
 148                 tcg_fords    = [] } ;
 149
 150              lcl_env = TcLclEnv {
 151                 tcl_ctxt   = [],
 152                 tcl_level  = topStage,
 153                 tcl_env    = emptyNameEnv,
 154                 tcl_tyvars = tvs_var,
 155                 tcl_lie    = panic "initTc:LIE" } ;
 156                         -- LIE only valid inside a getLIE
 157              } ;
 158
 159         -- OK, here's the business end!
 160         maybe_res <- catch (do { res  <- runTcRn env do_this ;
 161                                  return (Just res) })
 162                            (\_ -> return Nothing) ;
 163
 164         -- Print any error messages
 165         msgs <- readIORef errs_var ;
 166         printErrorsAndWarnings msgs ;
 167
 168         -- Get final PCS and return
 169         eps' <- readIORef eps_var ;
 170         nc'  <- readIORef nc_var ;
 171         let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ;
 172               final_res | errorsFound dflags msgs = Nothing
 173                         | otherwise               = maybe_res } ;
 174
 175         return (pcs', final_res)
 176     }
 177   where
 178     eps = pcs_EPS pcs
 179
 180     init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv }
 181         -- Initialise tcg_imports with an empty set of bindings for
 182         -- this module, so that if we see 'module M' in the export
 183         -- list, and there are no bindings in M, we don't bleat
 184         -- "unknown module M".
 185
 186 defaultDefaultTys :: [Type]
 187 defaultDefaultTys = [integerTy, doubleTy]
 188
 189 mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv
 190 mkImpInstEnv dflags eps hpt
 191   = foldModuleEnv (add . md_insts . hm_details)
 192                   (eps_inst_env eps)
 193                   hpt
 194   where
 195           -- We shouldn't get instance conflict errors from
 196           -- the package and home type envs
 197     add dfuns inst_env = WARN( not (null errs), vcat (map snd errs) ) inst_env'
 198                        where
 199                          (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 200
 201 -- mkImpTypeEnv makes the imported symbol table
 202 mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
 203              -> Name -> Maybe TyThing
 204 mkImpTypeEnv pcs hpt = lookup
 205   where
 206     pte = eps_PTE pcs
 207     lookup name | isInternalName name = Nothing
 208                 | otherwise           = lookupType hpt pte name
 209 \end{code}
 210
 211
 212 %************************************************************************
 213 %*                                                                      *
 214                 Simple accessors
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 \begin{code}
 219 getTopEnv :: TcRn m TopEnv
 220 getTopEnv = do { env <- getEnv; return (env_top env) }
 221
 222 getGblEnv :: TcRn m TcGblEnv
 223 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 224
 225 updGblEnv :: (TcGblEnv -> TcGblEnv) -> TcRn m a -> TcRn m a
 226 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
 227                           env { env_gbl = upd gbl })
 228
 229 setGblEnv :: TcGblEnv -> TcRn m a -> TcRn m a
 230 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 231
 232 getLclEnv :: TcRn m m
 233 getLclEnv = do { env <- getEnv; return (env_lcl env) }
 234
 235 updLclEnv :: (m -> m) -> TcRn m a -> TcRn m a
 236 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 237                           env { env_lcl = upd lcl })
 238
 239 setLclEnv :: m -> TcRn m a -> TcRn n a
 240 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
 241 \end{code}
 242
 243 Command-line flags
 244
 245 \begin{code}
 246 getDOpts :: TcRn m DynFlags
 247 getDOpts = do { env <- getTopEnv; return (top_dflags env) }
 248
 249 doptM :: DynFlag -> TcRn m Bool
 250 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 251
 252 ifOptM :: DynFlag -> TcRn m () -> TcRn m ()     -- Do it flag is true
 253 ifOptM flag thing_inside = do { b <- doptM flag;
 254                                 if b then thing_inside else return () }
 255
 256 getGhciMode :: TcRn m GhciMode
 257 getGhciMode = do { env <- getTopEnv; return (top_mode env) }
 258 \end{code}
 259
 260 \begin{code}
 261 getSrcLocM :: TcRn m SrcLoc
 262         -- Avoid clash with Name.getSrcLoc
 263 getSrcLocM = do { env <- getEnv; return (env_loc env) }
 264
 265 addSrcLoc :: SrcLoc -> TcRn m a -> TcRn m a
 266 addSrcLoc loc = updEnv (\env -> env { env_loc = loc })
 267 \end{code}
 268
 269 \begin{code}
 270 getEps :: TcRn m ExternalPackageState
 271 getEps = do { env <- getTopEnv; readMutVar (top_eps env) }
 272
 273 setEps :: ExternalPackageState -> TcRn m ()
 274 setEps eps = do { env <- getTopEnv; writeMutVar (top_eps env) eps }
 275
 276 getHpt :: TcRn m HomePackageTable
 277 getHpt = do { env <- getTopEnv; return (top_hpt env) }
 278
 279 getModule :: TcRn m Module
 280 getModule = do { env <- getGblEnv; return (tcg_mod env) }
 281
 282 getGlobalRdrEnv :: TcRn m GlobalRdrEnv
 283 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 284
 285 getImports :: TcRn m ImportAvails
 286 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 287
 288 getFixityEnv :: TcRn m FixityEnv
 289 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 290
 291 extendFixityEnv :: [(Name,FixitySig Name)] -> RnM a -> RnM a
 292 extendFixityEnv new_bit
 293   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
 294                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
 295
 296 getDefaultTys :: TcRn m [Type]
 297 getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 298 \end{code}
 299
 300 \begin{code}
 301 getUsageVar :: TcRn m (TcRef EntityUsage)
 302 getUsageVar = do { env <- getGblEnv; return (tcg_usages env) }
 303
 304 getUsages :: TcRn m EntityUsage
 305 getUsages = do { usg_var <- getUsageVar; readMutVar usg_var }
 306
 307 updUsages :: (EntityUsage -> EntityUsage) -> TcRn m ()
 308 updUsages upd = do { usg_var <- getUsageVar ;
 309                      usg <- readMutVar usg_var ;
 310                      writeMutVar usg_var (upd usg) }
 311 \end{code}
 312
 313
 314 %************************************************************************
 315 %*                                                                      *
 316                 Error management
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 \begin{code}
 321 getErrsVar :: TcRn m (TcRef Messages)
 322 getErrsVar = do { env <- getTopEnv; return (top_errs env) }
 323
 324 setErrsVar :: TcRef Messages -> TcRn m a -> TcRn m a
 325 setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
 326                          env { env_top = top_env { top_errs = v }})
 327
 328 addErr :: Message -> TcRn m ()
 329 addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg }
 330
 331 addErrAt :: SrcLoc -> Message -> TcRn m ()
 332 addErrAt loc msg
 333  = do {  errs_var <- getErrsVar ;
 334          rdr_env <- getGlobalRdrEnv ;
 335          let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ;
 336          (warns, errs) <- readMutVar errs_var ;
 337          writeMutVar errs_var (warns, errs `snocBag` err) }
 338
 339 addErrs :: [(SrcLoc,Message)] -> TcRn m ()
 340 addErrs msgs = mappM_ add msgs
 341              where
 342                add (loc,msg) = addErrAt loc msg
 343
 344 addWarn :: Message -> TcRn m ()
 345 addWarn msg
 346   = do { errs_var <- getErrsVar ;
 347          loc <- getSrcLocM ;
 348          rdr_env <- getGlobalRdrEnv ;
 349          let { warn = addShortWarnLocLine loc (unQualInScope rdr_env) msg } ;
 350          (warns, errs) <- readMutVar errs_var ;
 351          writeMutVar errs_var (warns `snocBag` warn, errs) }
 352
 353 checkErr :: Bool -> Message -> TcRn m ()
 354 -- Add the error if the bool is False
 355 checkErr ok msg = checkM ok (addErr msg)
 356
 357 warnIf :: Bool -> Message -> TcRn m ()
 358 warnIf True  msg = addWarn msg
 359 warnIf False msg = return ()
 360
 361 addMessages :: Messages -> TcRn m ()
 362 addMessages (m_warns, m_errs)
 363   = do { errs_var <- getErrsVar ;
 364          (warns, errs) <- readMutVar errs_var ;
 365          writeMutVar errs_var (warns `unionBags` m_warns,
 366                                errs  `unionBags` m_errs) }
 367
 368 checkGHCI :: Message -> TcRn m ()       -- Check that GHCI is on
 369                                         -- otherwise add the error message
 370 #ifdef GHCI
 371 checkGHCI m = returnM ()
 372 #else
 373 checkGHCI m = addErr m
 374 #endif
 375 \end{code}
 376
 377
 378 \begin{code}
 379 recoverM :: TcRn m r    -- Recovery action; do this if the main one fails
 380          -> TcRn m r    -- Main action: do this first
 381          -> TcRn m r
 382 recoverM recover thing
 383   = do { mb_res <- tryM thing ;
 384          case mb_res of
 385            Left exn  -> recover
 386            Right res -> returnM res }
 387
 388 tryTc :: TcRn m a -> TcRn m (Messages, Maybe a)
 389     -- (tryTc m) executes m, and returns
 390     --  Just r,  if m succeeds (returning r) and caused no errors
 391     --  Nothing, if m fails, or caused errors
 392     -- It also returns all the errors accumulated by m
 393     --  (even in the Just case, there might be warnings)
 394     --
 395     -- It always succeeds (never raises an exception)
 396 tryTc m
 397  = do { errs_var <- newMutVar emptyMessages ;
 398
 399         mb_r <- tryM (setErrsVar errs_var m) ;
 400
 401         new_errs <- readMutVar errs_var ;
 402
 403         dflags <- getDOpts ;
 404
 405         return (new_errs,
 406                 case mb_r of
 407                   Left exn                              -> Nothing
 408                   Right r | errorsFound dflags new_errs -> Nothing
 409                           | otherwise                   -> Just r)
 410    }
 411
 412 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 413 -- Just like tryTc, except that it ensures that the LIE
 414 -- for the thing is propagated only if there are no errors
 415 -- Hence it's restricted to the type-check monad
 416 tryTcLIE thing_inside
 417   = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ;
 418          ifM (isJust mb_r) (extendLIEs lie) ;
 419          return (errs, mb_r) }
 420
 421 tryTcLIE_ :: TcM r -> TcM r -> TcM r
 422 -- (tryM_ r m) tries m; if it succeeds it returns it,
 423 -- otherwise it returns r.  Any error messages added by m are discarded,
 424 -- whether or not m succeeds.
 425 tryTcLIE_ recover main
 426   = do { (_msgs, mb_res) <- tryTcLIE main ;
 427          case mb_res of
 428            Just res -> return res
 429            Nothing  -> recover }
 430
 431 checkNoErrs :: TcM r -> TcM r
 432 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 433 -- If m fails then (checkNoErrsTc m) fails.
 434 -- If m succeeds, it checks whether m generated any errors messages
 435 --      (it might have recovered internally)
 436 --      If so, it fails too.
 437 -- Regardless, any errors generated by m are propagated to the enclosing context.
 438 checkNoErrs main
 439   = do { (msgs, mb_res) <- tryTcLIE main ;
 440          addMessages msgs ;
 441          case mb_res of
 442            Just r  -> return r
 443            Nothing -> failM
 444    }
 445
 446 ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r
 447 --      ifErrsM bale_out main
 448 -- does 'bale_out' if there are errors in errors collection
 449 -- otherwise does 'main'
 450 ifErrsM bale_out normal
 451  = do { errs_var <- getErrsVar ;
 452         msgs <- readMutVar errs_var ;
 453         dflags <- getDOpts ;
 454         if errorsFound dflags msgs then
 455            bale_out
 456         else
 457            normal }
 458
 459 failIfErrsM :: TcRn m ()
 460 -- Useful to avoid error cascades
 461 failIfErrsM = ifErrsM failM (return ())
 462 \end{code}
 463
 464 \begin{code}
 465 forkM :: SDoc -> TcM a -> TcM (Maybe a)
 466 -- Run thing_inside in an interleaved thread.  It gets a separate
 467 --      * errs_var, and
 468 --      * unique supply,
 469 -- but everything else is shared, so this is DANGEROUS.
 470 --
 471 -- It returns Nothing if the computation fails
 472 --
 473 -- It's used for lazily type-checking interface
 474 -- signatures, which is pretty benign
 475
 476 forkM doc thing_inside
 477  = do { us <- newUniqueSupply ;
 478         unsafeInterleaveM $
 479         do { us_var <- newMutVar us ;
 480              (msgs, mb_res) <- tryTcLIE (setUsVar us_var thing_inside) ;
 481              case mb_res of
 482                 Just r  -> return (Just r)
 483                 Nothing -> do {
 484                     -- Bleat about errors in the forked thread
 485                     ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ;
 486                                    printErrorsAndWarnings msgs }) ;
 487                     return Nothing }
 488         }}
 489   where
 490     hdr_doc = text "forkM failed:" <+> doc
 491 \end{code}
 492
 493
 494 %************************************************************************
 495 %*                                                                      *
 496                 Unique supply
 497 %*                                                                      *
 498 %************************************************************************
 499
 500 \begin{code}
 501 getUsVar :: TcRn m (TcRef UniqSupply)
 502 getUsVar = do { env <- getTopEnv; return (top_us env) }
 503
 504 setUsVar :: TcRef UniqSupply -> TcRn m a -> TcRn m a
 505 setUsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
 506                        env { env_top = top_env { top_us = v }})
 507
 508 newUnique :: TcRn m Unique
 509 newUnique = do { us <- newUniqueSupply ;
 510                  return (uniqFromSupply us) }
 511
 512 newUniqueSupply :: TcRn m UniqSupply
 513 newUniqueSupply
 514  = do { u_var <- getUsVar ;
 515         us <- readMutVar u_var ;
 516         let { (us1, us2) = splitUniqSupply us } ;
 517         writeMutVar u_var us1 ;
 518         return us2 }
 519 \end{code}
 520
 521
 522 \begin{code}
 523 getNameCache :: TcRn m NameCache
 524 getNameCache = do { TopEnv { top_nc = nc_var } <- getTopEnv;
 525                     readMutVar nc_var }
 526
 527 setNameCache :: NameCache -> TcRn m ()
 528 setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv;
 529                        writeMutVar nc_var nc }
 530 \end{code}
 531
 532
 533 %************************************************************************
 534 %*                                                                      *
 535                 Debugging
 536 %*                                                                      *
 537 %************************************************************************
 538
 539 \begin{code}
 540 traceTc, traceRn :: SDoc -> TcRn a ()
 541 traceRn      = dumpOptTcRn Opt_D_dump_rn_trace
 542 traceTc      = dumpOptTcRn Opt_D_dump_tc_trace
 543 traceSplice  = dumpOptTcRn Opt_D_dump_splices
 544 traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs
 545
 546 dumpOptTcRn :: DynFlag -> SDoc -> TcRn a ()
 547 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
 548
 549 dumpTcRn :: SDoc -> TcRn a ()
 550 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
 551                     ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
 552 \end{code}
 553
 554
 555 %************************************************************************
 556 %*                                                                      *
 557         Context management and error message generation
 558                     for the type checker
 559 %*                                                                      *
 560 %************************************************************************
 561
 562 \begin{code}
 563 setErrCtxtM, addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
 564 setErrCtxtM msg = updCtxt (\ msgs -> [msg])
 565 addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
 566
 567 setErrCtxt, addErrCtxt :: Message -> TcM a -> TcM a
 568 setErrCtxt msg = setErrCtxtM (\env -> returnM (env, msg))
 569 addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
 570
 571 popErrCtxt :: TcM a -> TcM a
 572 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
 573
 574 getErrCtxt :: TcM ErrCtxt
 575 getErrCtxt = do { env <- getLclEnv ; return (tcl_ctxt env) }
 576
 577 -- Helper function for the above
 578 updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
 579 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
 580                            env { tcl_ctxt = upd ctxt })
 581
 582 getInstLoc :: InstOrigin -> TcM InstLoc
 583 getInstLoc origin
 584   = do { loc <- getSrcLocM ; env <- getLclEnv ;
 585          return (origin, loc, (tcl_ctxt env)) }
 586 \end{code}
 587
 588     The addErrTc functions add an error message, but do not cause failure.
 589     The 'M' variants pass a TidyEnv that has already been used to
 590     tidy up the message; we then use it to tidy the context messages
 591
 592 \begin{code}
 593 addErrTc :: Message -> TcM ()
 594 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 595
 596 addErrsTc :: [Message] -> TcM ()
 597 addErrsTc err_msgs = mappM_ addErrTc err_msgs
 598
 599 addErrTcM :: (TidyEnv, Message) -> TcM ()
 600 addErrTcM (tidy_env, err_msg)
 601   = do { ctxt <- getErrCtxt ;
 602          loc  <- getSrcLocM ;
 603          add_err_tcm tidy_env err_msg loc ctxt }
 604
 605 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> TcM ()
 606 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg)
 607   = add_err_tcm tidy_env err_msg loc full_ctxt
 608   where
 609     full_ctxt = (\env -> returnM (env, pprInstLoc inst_loc)) : ctxt
 610 \end{code}
 611
 612 The failWith functions add an error message and cause failure
 613
 614 \begin{code}
 615 failWithTc :: Message -> TcM a               -- Add an error message and fail
 616 failWithTc err_msg
 617   = addErrTc err_msg >> failM
 618
 619 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
 620 failWithTcM local_and_msg
 621   = addErrTcM local_and_msg >> failM
 622
 623 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
 624 checkTc True  err = returnM ()
 625 checkTc False err = failWithTc err
 626 \end{code}
 627
 628         Warnings have no 'M' variant, nor failure
 629
 630 \begin{code}
 631 addWarnTc :: Message -> TcM ()
 632 addWarnTc msg
 633  = do { ctxt <- getErrCtxt ;
 634         ctxt_msgs <- do_ctxt emptyTidyEnv ctxt ;
 635         addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
 636
 637 warnTc :: Bool -> Message -> TcM ()
 638 warnTc warn_if_true warn_msg
 639   | warn_if_true = addWarnTc warn_msg
 640   | otherwise    = return ()
 641 \end{code}
 642
 643         Helper functions
 644
 645 \begin{code}
 646 add_err_tcm tidy_env err_msg loc ctxt
 647  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
 648         addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
 649
 650 do_ctxt tidy_env []
 651  = return []
 652 do_ctxt tidy_env (c:cs)
 653  = do { (tidy_env', m) <- c tidy_env  ;
 654         ms             <- do_ctxt tidy_env' cs  ;
 655         return (m:ms) }
 656
 657 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 658                  | otherwise          = take 3 ctxt
 659 \end{code}
 660
 661 %************************************************************************
 662 %*                                                                      *
 663              Other stuff specific to type checker
 664 %*                                                                      *
 665 %************************************************************************
 666
 667 \begin{code}
 668 getLIEVar :: TcM (TcRef LIE)
 669 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
 670
 671 setLIEVar :: TcRef LIE -> TcM a -> TcM a
 672 setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 673
 674 getLIE :: TcM a -> TcM (a, [Inst])
 675 -- (getLIE m) runs m, and returns the type constraints it generates
 676 getLIE thing_inside
 677   = do { lie_var <- newMutVar emptyLIE ;
 678          res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
 679                           thing_inside ;
 680          lie <- readMutVar lie_var ;
 681          return (res, lieToList lie) }
 682
 683 extendLIE :: Inst -> TcM ()
 684 extendLIE inst
 685   = do { lie_var <- getLIEVar ;
 686          lie <- readMutVar lie_var ;
 687          writeMutVar lie_var (inst `consLIE` lie) }
 688
 689 extendLIEs :: [Inst] -> TcM ()
 690 extendLIEs []
 691   = returnM ()
 692 extendLIEs insts
 693   = do { lie_var <- getLIEVar ;
 694          lie <- readMutVar lie_var ;
 695          writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
 696 \end{code}
 697
 698
 699 \begin{code}
 700 getStage :: TcM Stage
 701 getStage = do { env <- getLclEnv; return (tcl_level env) }
 702
 703 setStage :: Stage -> TcM a -> TcM a
 704 setStage s = updLclEnv (\ env -> env { tcl_level = s })
 705
 706 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
 707 -- Set the local type envt, but do *not* disturb other fields,
 708 -- notably the lie_var
 709 setLclTypeEnv lcl_env thing_inside
 710   = updLclEnv upd thing_inside
 711   where
 712     upd env = env { tcl_env = tcl_env lcl_env,
 713                     tcl_tyvars = tcl_tyvars lcl_env }
 714 \end{code}
 715
 716
 717 %************************************************************************
 718 %*                                                                      *
 719              Stuff for the renamer's local env
 720 %*                                                                      *
 721 %************************************************************************
 722
 723 \begin{code}
 724 initRn :: RnMode -> RnM a -> TcRn m a
 725 initRn mode thing_inside
 726  = do { env <- getGblEnv ;
 727         let { lcl_env = RnLclEnv {
 728                              rn_mode = mode,
 729                              rn_lenv = emptyRdrEnv }} ;
 730         setLclEnv lcl_env thing_inside }
 731 \end{code}
 732
 733 \begin{code}
 734 getLocalRdrEnv :: RnM LocalRdrEnv
 735 getLocalRdrEnv = do { env <- getLclEnv; return (rn_lenv env) }
 736
 737 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
 738 setLocalRdrEnv rdr_env thing_inside
 739   = updLclEnv (\env -> env {rn_lenv = rdr_env}) thing_inside
 740
 741 getModeRn :: RnM RnMode
 742 getModeRn = do { env <- getLclEnv; return (rn_mode env) }
 743 \end{code}
 744