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