compiler/typecheck/TcRnMonad.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 module TcRnMonad(
   7         module TcRnMonad,
   8         module TcRnTypes,
   9         module IOEnv
  10   ) where
  11
  12 import TcRnTypes        -- Re-export all
  13 import IOEnv            -- Re-export all
  14
  15 import HsSyn hiding (LIE)
  16 import HscTypes
  17 import Module
  18 import RdrName
  19 import Name
  20 import TcType
  21 import InstEnv
  22 import FamInstEnv
  23
  24 import Var
  25 import Id
  26 import VarSet
  27 import VarEnv
  28 import ErrUtils
  29 import SrcLoc
  30 import NameEnv
  31 import NameSet
  32 import OccName
  33 import Bag
  34 import Outputable
  35 import UniqSupply
  36 import Unique
  37 import LazyUniqFM
  38 import DynFlags
  39 import StaticFlags
  40 import FastString
  41 import Panic
  42 import Util
  43
  44 import System.IO
  45 import Data.IORef
  46 import Control.Exception
  47 import Control.Monad
  48 \end{code}
  49
  50
  51
  52 %************************************************************************
  53 %*                                                                      *
  54                         initTc
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 \begin{code}
  59
  60 initTc :: HscEnv
  61        -> HscSource
  62        -> Bool          -- True <=> retain renamed syntax trees
  63        -> Module
  64        -> TcM r
  65        -> IO (Messages, Maybe r)
  66                 -- Nothing => error thrown by the thing inside
  67                 -- (error messages should have been printed already)
  68
  69 initTc hsc_env hsc_src keep_rn_syntax mod do_this
  70  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
  71         tvs_var      <- newIORef emptyVarSet ;
  72         type_env_var <- newIORef emptyNameEnv ;
  73         dfuns_var    <- newIORef emptyNameSet ;
  74         keep_var     <- newIORef emptyNameSet ;
  75         th_var       <- newIORef False ;
  76         dfun_n_var   <- newIORef 1 ;
  77         let {
  78              maybe_rn_syntax empty_val
  79                 | keep_rn_syntax = Just empty_val
  80                 | otherwise      = Nothing ;
  81
  82              gbl_env = TcGblEnv {
  83                 tcg_mod       = mod,
  84                 tcg_src       = hsc_src,
  85                 tcg_rdr_env   = hsc_global_rdr_env hsc_env,
  86                 tcg_fix_env   = emptyNameEnv,
  87                 tcg_field_env = emptyNameEnv,
  88                 tcg_default   = Nothing,
  89                 tcg_type_env  = hsc_global_type_env hsc_env,
  90                 tcg_type_env_var = type_env_var,
  91                 tcg_inst_env  = emptyInstEnv,
  92                 tcg_fam_inst_env  = emptyFamInstEnv,
  93                 tcg_inst_uses = dfuns_var,
  94                 tcg_th_used   = th_var,
  95                 tcg_exports  = [],
  96                 tcg_imports  = emptyImportAvails,
  97                 tcg_dus      = emptyDUs,
  98
  99                 tcg_rn_imports = maybe_rn_syntax [],
 100                 tcg_rn_exports = maybe_rn_syntax [],
 101                 tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
 102
 103                 tcg_binds    = emptyLHsBinds,
 104                 tcg_deprecs  = NoDeprecs,
 105                 tcg_insts    = [],
 106                 tcg_fam_insts= [],
 107                 tcg_rules    = [],
 108                 tcg_fords    = [],
 109                 tcg_dfun_n   = dfun_n_var,
 110                 tcg_keep     = keep_var,
 111                 tcg_doc      = Nothing,
 112                 tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
 113                 tcg_hpc      = False
 114              } ;
 115              lcl_env = TcLclEnv {
 116                 tcl_errs       = errs_var,
 117                 tcl_loc        = mkGeneralSrcSpan (fsLit "Top level"),
 118                 tcl_ctxt       = [],
 119                 tcl_rdr        = emptyLocalRdrEnv,
 120                 tcl_th_ctxt    = topStage,
 121                 tcl_arrow_ctxt = NoArrowCtxt,
 122                 tcl_env        = emptyNameEnv,
 123                 tcl_tyvars     = tvs_var,
 124                 tcl_lie        = panic "initTc:LIE"     -- LIE only valid inside a getLIE
 125              } ;
 126         } ;
 127
 128         -- OK, here's the business end!
 129         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
 130                      do { r <- tryM do_this
 131                         ; case r of
 132                           Right res -> return (Just res)
 133                           Left _    -> return Nothing } ;
 134
 135         -- Collect any error messages
 136         msgs <- readIORef errs_var ;
 137
 138         let { dflags = hsc_dflags hsc_env
 139             ; final_res | errorsFound dflags msgs = Nothing
 140                         | otherwise               = maybe_res } ;
 141
 142         return (msgs, final_res)
 143     }
 144
 145 initTcPrintErrors       -- Used from the interactive loop only
 146        :: HscEnv
 147        -> Module
 148        -> TcM r
 149        -> IO (Maybe r)
 150 initTcPrintErrors env mod todo = do
 151   (msgs, res) <- initTc env HsSrcFile False mod todo
 152   printErrorsAndWarnings (hsc_dflags env) msgs
 153   return res
 154 \end{code}
 155
 156 %************************************************************************
 157 %*                                                                      *
 158                 Initialisation
 159 %*                                                                      *
 160 %************************************************************************
 161
 162
 163 \begin{code}
 164 initTcRnIf :: Char              -- Tag for unique supply
 165            -> HscEnv
 166            -> gbl -> lcl
 167            -> TcRnIf gbl lcl a
 168            -> IO a
 169 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
 170    = do { us     <- mkSplitUniqSupply uniq_tag ;
 171         ; us_var <- newIORef us ;
 172
 173         ; let { env = Env { env_top = hsc_env,
 174                             env_us  = us_var,
 175                             env_gbl = gbl_env,
 176                             env_lcl = lcl_env} }
 177
 178         ; runIOEnv env thing_inside
 179         }
 180 \end{code}
 181
 182 %************************************************************************
 183 %*                                                                      *
 184                 Simple accessors
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 \begin{code}
 189 getTopEnv :: TcRnIf gbl lcl HscEnv
 190 getTopEnv = do { env <- getEnv; return (env_top env) }
 191
 192 getGblEnv :: TcRnIf gbl lcl gbl
 193 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 194
 195 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 196 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
 197                           env { env_gbl = upd gbl })
 198
 199 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 200 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 201
 202 getLclEnv :: TcRnIf gbl lcl lcl
 203 getLclEnv = do { env <- getEnv; return (env_lcl env) }
 204
 205 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 206 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 207                           env { env_lcl = upd lcl })
 208
 209 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
 210 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
 211
 212 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
 213 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
 214
 215 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
 216 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 217 \end{code}
 218
 219
 220 Command-line flags
 221
 222 \begin{code}
 223 getDOpts :: TcRnIf gbl lcl DynFlags
 224 getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
 225
 226 doptM :: DynFlag -> TcRnIf gbl lcl Bool
 227 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 228
 229 setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 230 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
 231                          env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
 232
 233 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 234 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
 235                          env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
 236
 237 -- | Do it flag is true
 238 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 239 ifOptM flag thing_inside = do { b <- doptM flag;
 240                                 if b then thing_inside else return () }
 241
 242 getGhcMode :: TcRnIf gbl lcl GhcMode
 243 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 244 \end{code}
 245
 246 \begin{code}
 247 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
 248 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 249
 250 getEps :: TcRnIf gbl lcl ExternalPackageState
 251 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 252
 253 -- Updating the EPS.  This should be an atomic operation.
 254 -- Note the delicate 'seq' which forces the EPS before putting it in the
 255 -- variable.  Otherwise what happens is that we get
 256 --      write eps_var (....(unsafeRead eps_var)....)
 257 -- and if the .... is strict, that's obviously bottom.  By forcing it beforehand
 258 -- we make the unsafeRead happen before we update the variable.
 259
 260 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
 261           -> TcRnIf gbl lcl a
 262 updateEps upd_fn = do   { traceIf (text "updating EPS")
 263                         ; eps_var <- getEpsVar
 264                         ; eps <- readMutVar eps_var
 265                         ; let { (eps', val) = upd_fn eps }
 266                         ; seq eps' (writeMutVar eps_var eps')
 267                         ; return val }
 268
 269 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
 270            -> TcRnIf gbl lcl ()
 271 updateEps_ upd_fn = do  { traceIf (text "updating EPS_")
 272                         ; eps_var <- getEpsVar
 273                         ; eps <- readMutVar eps_var
 274                         ; let { eps' = upd_fn eps }
 275                         ; seq eps' (writeMutVar eps_var eps') }
 276
 277 getHpt :: TcRnIf gbl lcl HomePackageTable
 278 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
 279
 280 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
 281 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 282                   ; return (eps, hsc_HPT env) }
 283 \end{code}
 284
 285 %************************************************************************
 286 %*                                                                      *
 287                 Unique supply
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 newUnique :: TcRnIf gbl lcl Unique
 293 newUnique
 294  = do { env <- getEnv ;
 295         let { u_var = env_us env } ;
 296         us <- readMutVar u_var ;
 297         case splitUniqSupply us of { (us1,_) -> do {
 298         writeMutVar u_var us1 ;
 299         return $! uniqFromSupply us }}}
 300    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
 301    -- a chain of unevaluated supplies behind.
 302    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
 303    -- throw away one half of the new split supply.  This is safe because this
 304    -- is the only place we use that unique.  Using the other half of the split
 305    -- supply is safer, but slower.
 306
 307 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 308 newUniqueSupply
 309  = do { env <- getEnv ;
 310         let { u_var = env_us env } ;
 311         us <- readMutVar u_var ;
 312         case splitUniqSupply us of { (us1,us2) -> do {
 313         writeMutVar u_var us1 ;
 314         return us2 }}}
 315
 316 newLocalName :: Name -> TcRnIf gbl lcl Name
 317 newLocalName name       -- Make a clone
 318   = do  { uniq <- newUnique
 319         ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
 320
 321 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 322 newSysLocalIds fs tys
 323   = do  { us <- newUniqueSupply
 324         ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
 325 \end{code}
 326
 327
 328 %************************************************************************
 329 %*                                                                      *
 330                 Debugging
 331 %*                                                                      *
 332 %************************************************************************
 333
 334 \begin{code}
 335 traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
 336 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 337 traceTc      = traceOptTcRn Opt_D_dump_tc_trace
 338 traceSplice  = traceOptTcRn Opt_D_dump_splices
 339
 340
 341 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 342 traceIf      = traceOptIf Opt_D_dump_if_trace
 343 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 344
 345
 346 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
 347 traceOptIf flag doc = ifOptM flag $
 348                       liftIO (printForUser stderr alwaysQualify doc)
 349
 350 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
 351 traceOptTcRn flag doc = ifOptM flag $ do
 352                         { ctxt <- getErrCtxt
 353                         ; loc  <- getSrcSpanM
 354                         ; env0 <- tcInitTidyEnv
 355                         ; ctxt_msgs <- do_ctxt env0 ctxt
 356                         ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
 357                         ; dumpTcRn real_doc }
 358
 359 dumpTcRn :: SDoc -> TcRn ()
 360 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
 361                     dflags <- getDOpts ;
 362                     liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
 363
 364 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
 365 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
 366 \end{code}
 367
 368
 369 %************************************************************************
 370 %*                                                                      *
 371                 Typechecker global environment
 372 %*                                                                      *
 373 %************************************************************************
 374
 375 \begin{code}
 376 getModule :: TcRn Module
 377 getModule = do { env <- getGblEnv; return (tcg_mod env) }
 378
 379 setModule :: Module -> TcRn a -> TcRn a
 380 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
 381
 382 tcIsHsBoot :: TcRn Bool
 383 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 384
 385 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 386 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 387
 388 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
 389 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
 390
 391 getImports :: TcRn ImportAvails
 392 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 393
 394 getFixityEnv :: TcRn FixityEnv
 395 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 396
 397 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
 398 extendFixityEnv new_bit
 399   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
 400                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
 401
 402 getRecFieldEnv :: TcRn RecFieldEnv
 403 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
 404
 405 extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a
 406 extendRecFieldEnv new_bit
 407   = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) ->
 408                 env {tcg_field_env = old_env `plusNameEnv` new_bit})
 409
 410 getDeclaredDefaultTys :: TcRn (Maybe [Type])
 411 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 412 \end{code}
 413
 414 %************************************************************************
 415 %*                                                                      *
 416                 Error management
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 \begin{code}
 421 getSrcSpanM :: TcRn SrcSpan
 422         -- Avoid clash with Name.getSrcLoc
 423 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
 424
 425 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
 426 setSrcSpan loc thing_inside
 427   | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
 428   | otherwise         = thing_inside    -- Don't overwrite useful info with useless
 429
 430 addLocM :: (a -> TcM b) -> Located a -> TcM b
 431 addLocM fn (L loc a) = setSrcSpan loc $ fn a
 432
 433 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
 434 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
 435
 436 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
 437 wrapLocFstM fn (L loc a) =
 438   setSrcSpan loc $ do
 439     (b,c) <- fn a
 440     return (L loc b, c)
 441
 442 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
 443 wrapLocSndM fn (L loc a) =
 444   setSrcSpan loc $ do
 445     (b,c) <- fn a
 446     return (b, L loc c)
 447 \end{code}
 448
 449
 450 \begin{code}
 451 getErrsVar :: TcRn (TcRef Messages)
 452 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 453
 454 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 455 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 456
 457 addErr :: Message -> TcRn ()
 458 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 459
 460 addLocErr :: Located e -> (e -> Message) -> TcRn ()
 461 addLocErr (L loc e) fn = addErrAt loc (fn e)
 462
 463 addErrAt :: SrcSpan -> Message -> TcRn ()
 464 addErrAt loc msg = addLongErrAt loc msg empty
 465
 466 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 467 addLongErrAt loc msg extra
 468   = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
 469          errs_var <- getErrsVar ;
 470          rdr_env <- getGlobalRdrEnv ;
 471          dflags <- getDOpts ;
 472          let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
 473          (warns, errs) <- readMutVar errs_var ;
 474          writeMutVar errs_var (warns, errs `snocBag` err) }
 475
 476 addErrs :: [(SrcSpan,Message)] -> TcRn ()
 477 addErrs msgs = mapM_ add msgs
 478              where
 479                add (loc,msg) = addErrAt loc msg
 480
 481 addReport :: Message -> TcRn ()
 482 addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
 483
 484 addReportAt :: SrcSpan -> Message -> TcRn ()
 485 addReportAt loc msg
 486   = do { errs_var <- getErrsVar ;
 487          rdr_env <- getGlobalRdrEnv ;
 488          dflags <- getDOpts ;
 489          let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
 490          (warns, errs) <- readMutVar errs_var ;
 491          writeMutVar errs_var (warns `snocBag` warn, errs) }
 492
 493 addWarn :: Message -> TcRn ()
 494 addWarn msg = addReport (ptext (sLit "Warning:") <+> msg)
 495
 496 addWarnAt :: SrcSpan -> Message -> TcRn ()
 497 addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg)
 498
 499 addLocWarn :: Located e -> (e -> Message) -> TcRn ()
 500 addLocWarn (L loc e) fn = addReportAt loc (fn e)
 501
 502 checkErr :: Bool -> Message -> TcRn ()
 503 -- Add the error if the bool is False
 504 checkErr ok msg = unless ok (addErr msg)
 505
 506 warnIf :: Bool -> Message -> TcRn ()
 507 warnIf True  msg = addWarn msg
 508 warnIf False _   = return ()
 509
 510 addMessages :: Messages -> TcRn ()
 511 addMessages (m_warns, m_errs)
 512   = do { errs_var <- getErrsVar ;
 513          (warns, errs) <- readMutVar errs_var ;
 514          writeMutVar errs_var (warns `unionBags` m_warns,
 515                                errs  `unionBags` m_errs) }
 516
 517 discardWarnings :: TcRn a -> TcRn a
 518 -- Ignore warnings inside the thing inside;
 519 -- used to ignore-unused-variable warnings inside derived code
 520 -- With -dppr-debug, the effects is switched off, so you can still see
 521 -- what warnings derived code would give
 522 discardWarnings thing_inside
 523   | opt_PprStyle_Debug = thing_inside
 524   | otherwise
 525   = do  { errs_var <- newMutVar emptyMessages
 526         ; result <- setErrsVar errs_var thing_inside
 527         ; (_warns, errs) <- readMutVar errs_var
 528         ; addMessages (emptyBag, errs)
 529         ; return result }
 530 \end{code}
 531
 532
 533 \begin{code}
 534 try_m :: TcRn r -> TcRn (Either Exception r)
 535 -- Does try_m, with a debug-trace on failure
 536 try_m thing
 537   = do { mb_r <- tryM thing ;
 538          case mb_r of
 539              Left exn -> do { traceTc (exn_msg exn); return mb_r }
 540              Right _  -> return mb_r }
 541   where
 542     exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
 543
 544 -----------------------
 545 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
 546          -> TcRn r      -- Main action: do this first
 547          -> TcRn r
 548 -- Errors in 'thing' are retained
 549 recoverM recover thing
 550   = do { mb_res <- try_m thing ;
 551          case mb_res of
 552            Left _    -> recover
 553            Right res -> return res }
 554
 555
 556 -----------------------
 557 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
 558 -- Drop elements of the input that fail, so the result
 559 -- list can be shorter than the argument list
 560 mapAndRecoverM _ []     = return []
 561 mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x)
 562                              ; rs <- mapAndRecoverM f xs
 563                              ; return (case mb_r of
 564                                           Left _  -> rs
 565                                           Right r -> r:rs) }
 566
 567
 568 -----------------------
 569 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 570 -- (tryTc m) executes m, and returns
 571 --      Just r,  if m succeeds (returning r)
 572 --      Nothing, if m fails
 573 -- It also returns all the errors and warnings accumulated by m
 574 -- It always succeeds (never raises an exception)
 575 tryTc m
 576  = do { errs_var <- newMutVar emptyMessages ;
 577         res  <- try_m (setErrsVar errs_var m) ;
 578         msgs <- readMutVar errs_var ;
 579         return (msgs, case res of
 580                             Left _  -> Nothing
 581                             Right val -> Just val)
 582         -- The exception is always the IOEnv built-in
 583         -- in exception; see IOEnv.failM
 584    }
 585
 586 -----------------------
 587 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
 588 -- Run the thing, returning
 589 --      Just r,  if m succceeds with no error messages
 590 --      Nothing, if m fails, or if it succeeds but has error messages
 591 -- Either way, the messages are returned; even in the Just case
 592 -- there might be warnings
 593 tryTcErrs thing
 594   = do  { (msgs, res) <- tryTc thing
 595         ; dflags <- getDOpts
 596         ; let errs_found = errorsFound dflags msgs
 597         ; return (msgs, case res of
 598                           Nothing -> Nothing
 599                           Just val | errs_found -> Nothing
 600                                    | otherwise  -> Just val)
 601         }
 602
 603 -----------------------
 604 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 605 -- Just like tryTcErrs, except that it ensures that the LIE
 606 -- for the thing is propagated only if there are no errors
 607 -- Hence it's restricted to the type-check monad
 608 tryTcLIE thing_inside
 609   = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
 610         ; case mb_res of
 611             Nothing  -> return (msgs, Nothing)
 612             Just val -> do { extendLIEs lie; return (msgs, Just val) }
 613         }
 614
 615 -----------------------
 616 tryTcLIE_ :: TcM r -> TcM r -> TcM r
 617 -- (tryTcLIE_ r m) tries m;
 618 --      if m succeeds with no error messages, it's the answer
 619 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
 620 tryTcLIE_ recover main
 621   = do  { (msgs, mb_res) <- tryTcLIE main
 622         ; case mb_res of
 623              Just val -> do { addMessages msgs  -- There might be warnings
 624                              ; return val }
 625              Nothing  -> recover                -- Discard all msgs
 626         }
 627
 628 -----------------------
 629 checkNoErrs :: TcM r -> TcM r
 630 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 631 -- If m fails then (checkNoErrsTc m) fails.
 632 -- If m succeeds, it checks whether m generated any errors messages
 633 --      (it might have recovered internally)
 634 --      If so, it fails too.
 635 -- Regardless, any errors generated by m are propagated to the enclosing context.
 636 checkNoErrs main
 637   = do  { (msgs, mb_res) <- tryTcLIE main
 638         ; addMessages msgs
 639         ; case mb_res of
 640             Nothing  -> failM
 641             Just val -> return val
 642         }
 643
 644 ifErrsM :: TcRn r -> TcRn r -> TcRn r
 645 --      ifErrsM bale_out main
 646 -- does 'bale_out' if there are errors in errors collection
 647 -- otherwise does 'main'
 648 ifErrsM bale_out normal
 649  = do { errs_var <- getErrsVar ;
 650         msgs <- readMutVar errs_var ;
 651         dflags <- getDOpts ;
 652         if errorsFound dflags msgs then
 653            bale_out
 654         else
 655            normal }
 656
 657 failIfErrsM :: TcRn ()
 658 -- Useful to avoid error cascades
 659 failIfErrsM = ifErrsM failM (return ())
 660 \end{code}
 661
 662
 663 %************************************************************************
 664 %*                                                                      *
 665         Context management and error message generation
 666                     for the type checker
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 \begin{code}
 671 getErrCtxt :: TcM ErrCtxt
 672 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 673
 674 setErrCtxt :: ErrCtxt -> TcM a -> TcM a
 675 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 676
 677 addErrCtxt :: Message -> TcM a -> TcM a
 678 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 679
 680 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
 681 addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
 682
 683 -- Helper function for the above
 684 updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
 685 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
 686                            env { tcl_ctxt = upd ctxt })
 687
 688 -- Conditionally add an error context
 689 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
 690 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
 691 maybeAddErrCtxt Nothing    thing_inside = thing_inside
 692
 693 popErrCtxt :: TcM a -> TcM a
 694 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 695
 696 getInstLoc :: InstOrigin -> TcM InstLoc
 697 getInstLoc origin
 698   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
 699          return (InstLoc origin loc (tcl_ctxt env)) }
 700
 701 addInstCtxt :: InstLoc -> TcM a -> TcM a
 702 -- Add the SrcSpan and context from the first Inst in the list
 703 --      (they all have similar locations)
 704 addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
 705   = setSrcSpan src_loc (updCtxt (\_ -> ctxt) thing_inside)
 706 \end{code}
 707
 708     The addErrTc functions add an error message, but do not cause failure.
 709     The 'M' variants pass a TidyEnv that has already been used to
 710     tidy up the message; we then use it to tidy the context messages
 711
 712 \begin{code}
 713 addErrTc :: Message -> TcM ()
 714 addErrTc err_msg = do { env0 <- tcInitTidyEnv
 715                       ; addErrTcM (env0, err_msg) }
 716
 717 addErrsTc :: [Message] -> TcM ()
 718 addErrsTc err_msgs = mapM_ addErrTc err_msgs
 719
 720 addErrTcM :: (TidyEnv, Message) -> TcM ()
 721 addErrTcM (tidy_env, err_msg)
 722   = do { ctxt <- getErrCtxt ;
 723          loc  <- getSrcSpanM ;
 724          add_err_tcm tidy_env err_msg loc ctxt }
 725 \end{code}
 726
 727 The failWith functions add an error message and cause failure
 728
 729 \begin{code}
 730 failWithTc :: Message -> TcM a               -- Add an error message and fail
 731 failWithTc err_msg
 732   = addErrTc err_msg >> failM
 733
 734 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
 735 failWithTcM local_and_msg
 736   = addErrTcM local_and_msg >> failM
 737
 738 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
 739 checkTc True  _   = return ()
 740 checkTc False err = failWithTc err
 741 \end{code}
 742
 743         Warnings have no 'M' variant, nor failure
 744
 745 \begin{code}
 746 addWarnTc :: Message -> TcM ()
 747 addWarnTc msg = do { env0 <- tcInitTidyEnv
 748                    ; addWarnTcM (env0, msg) }
 749
 750 addWarnTcM :: (TidyEnv, Message) -> TcM ()
 751 addWarnTcM (env0, msg)
 752  = do { ctxt <- getErrCtxt ;
 753         ctxt_msgs <- do_ctxt env0 ctxt ;
 754         addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
 755
 756 warnTc :: Bool -> Message -> TcM ()
 757 warnTc warn_if_true warn_msg
 758   | warn_if_true = addWarnTc warn_msg
 759   | otherwise    = return ()
 760 \end{code}
 761
 762 -----------------------------------
 763          Tidying
 764
 765 We initialise the "tidy-env", used for tidying types before printing,
 766 by building a reverse map from the in-scope type variables to the
 767 OccName that the programmer originally used for them
 768
 769 \begin{code}
 770 tcInitTidyEnv :: TcM TidyEnv
 771 tcInitTidyEnv
 772   = do  { lcl_env <- getLclEnv
 773         ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
 774                           | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
 775                           , tcIsTyVarTy ty ]
 776         ; return (foldl add emptyTidyEnv nm_tv_prs) }
 777   where
 778     add (env,subst) (name, tyvar)
 779         = case tidyOccName env (nameOccName name) of
 780             (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
 781                 where
 782                   tyvar' = setTyVarName tyvar name'
 783                   name'  = tidyNameOcc name occ'
 784 \end{code}
 785
 786 -----------------------------------
 787         Other helper functions
 788
 789 \begin{code}
 790 add_err_tcm :: TidyEnv -> Message -> SrcSpan
 791             -> [TidyEnv -> TcM (TidyEnv, SDoc)]
 792             -> TcM ()
 793 add_err_tcm tidy_env err_msg loc ctxt
 794  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
 795         addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
 796
 797 do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc]
 798 do_ctxt _ []
 799  = return []
 800 do_ctxt tidy_env (c:cs)
 801  = do { (tidy_env', m) <- c tidy_env  ;
 802         ms             <- do_ctxt tidy_env' cs  ;
 803         return (m:ms) }
 804
 805 ctxt_to_use :: [SDoc] -> [SDoc]
 806 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 807                  | otherwise          = take 3 ctxt
 808 \end{code}
 809
 810 debugTc is useful for monadic debugging code
 811
 812 \begin{code}
 813 debugTc :: TcM () -> TcM ()
 814 debugTc thing
 815  | debugIsOn = thing
 816  | otherwise = return ()
 817 \end{code}
 818
 819  %************************************************************************
 820 %*                                                                      *
 821              Type constraints (the so-called LIE)
 822 %*                                                                      *
 823 %************************************************************************
 824
 825 \begin{code}
 826 nextDFunIndex :: TcM Int        -- Get the next dfun index
 827 nextDFunIndex = do { env <- getGblEnv
 828                    ; let dfun_n_var = tcg_dfun_n env
 829                    ; n <- readMutVar dfun_n_var
 830                    ; writeMutVar dfun_n_var (n+1)
 831                    ; return n }
 832
 833 getLIEVar :: TcM (TcRef LIE)
 834 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
 835
 836 setLIEVar :: TcRef LIE -> TcM a -> TcM a
 837 setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 838
 839 getLIE :: TcM a -> TcM (a, [Inst])
 840 -- (getLIE m) runs m, and returns the type constraints it generates
 841 getLIE thing_inside
 842   = do { lie_var <- newMutVar emptyLIE ;
 843          res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
 844                           thing_inside ;
 845          lie <- readMutVar lie_var ;
 846          return (res, lieToList lie) }
 847
 848 extendLIE :: Inst -> TcM ()
 849 extendLIE inst
 850   = do { lie_var <- getLIEVar ;
 851          lie <- readMutVar lie_var ;
 852          writeMutVar lie_var (inst `consLIE` lie) }
 853
 854 extendLIEs :: [Inst] -> TcM ()
 855 extendLIEs []
 856   = return ()
 857 extendLIEs insts
 858   = do { lie_var <- getLIEVar ;
 859          lie <- readMutVar lie_var ;
 860          writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
 861 \end{code}
 862
 863 \begin{code}
 864 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
 865 -- Set the local type envt, but do *not* disturb other fields,
 866 -- notably the lie_var
 867 setLclTypeEnv lcl_env thing_inside
 868   = updLclEnv upd thing_inside
 869   where
 870     upd env = env { tcl_env = tcl_env lcl_env,
 871                     tcl_tyvars = tcl_tyvars lcl_env }
 872 \end{code}
 873
 874
 875 %************************************************************************
 876 %*                                                                      *
 877              Template Haskell context
 878 %*                                                                      *
 879 %************************************************************************
 880
 881 \begin{code}
 882 recordThUse :: TcM ()
 883 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
 884
 885 keepAliveTc :: Id -> TcM ()     -- Record the name in the keep-alive set
 886 keepAliveTc id
 887   | isLocalId id = do { env <- getGblEnv;
 888                       ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
 889   | otherwise = return ()
 890
 891 keepAliveSetTc :: NameSet -> TcM ()     -- Record the name in the keep-alive set
 892 keepAliveSetTc ns = do { env <- getGblEnv;
 893                        ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
 894
 895 getStage :: TcM ThStage
 896 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
 897
 898 setStage :: ThStage -> TcM a -> TcM a
 899 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 900 \end{code}
 901
 902
 903 %************************************************************************
 904 %*                                                                      *
 905              Stuff for the renamer's local env
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 \begin{code}
 910 getLocalRdrEnv :: RnM LocalRdrEnv
 911 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
 912
 913 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
 914 setLocalRdrEnv rdr_env thing_inside
 915   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
 916 \end{code}
 917
 918
 919 %************************************************************************
 920 %*                                                                      *
 921              Stuff for interface decls
 922 %*                                                                      *
 923 %************************************************************************
 924
 925 \begin{code}
 926 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
 927 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
 928                                 if_loc     = loc,
 929                                 if_tv_env  = emptyUFM,
 930                                 if_id_env  = emptyUFM }
 931
 932 initIfaceTcRn :: IfG a -> TcRn a
 933 initIfaceTcRn thing_inside
 934   = do  { tcg_env <- getGblEnv
 935         ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
 936               ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
 937         ; setEnvs (if_env, ()) thing_inside }
 938
 939 initIfaceExtCore :: IfL a -> TcRn a
 940 initIfaceExtCore thing_inside
 941   = do  { tcg_env <- getGblEnv
 942         ; let { mod = tcg_mod tcg_env
 943               ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
 944               ; if_env = IfGblEnv {
 945                         if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
 946               ; if_lenv = mkIfLclEnv mod doc
 947           }
 948         ; setEnvs (if_env, if_lenv) thing_inside }
 949
 950 initIfaceCheck :: HscEnv -> IfG a -> IO a
 951 -- Used when checking the up-to-date-ness of the old Iface
 952 -- Initialise the environment with no useful info at all
 953 initIfaceCheck hsc_env do_this
 954  = do   { let gbl_env = IfGblEnv { if_rec_types = Nothing }
 955         ; initTcRnIf 'i' hsc_env gbl_env () do_this
 956     }
 957
 958 initIfaceTc :: ModIface
 959             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
 960 -- Used when type-checking checking an up-to-date interface file
 961 -- No type envt from the current module, but we do know the module dependencies
 962 initIfaceTc iface do_this
 963  = do   { tc_env_var <- newMutVar emptyTypeEnv
 964         ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
 965               ; if_lenv = mkIfLclEnv mod doc
 966            }
 967         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
 968     }
 969   where
 970     mod = mi_module iface
 971     doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
 972
 973 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
 974 -- Used when sucking in new Rules in SimplCore
 975 -- We have available the type envt of the module being compiled, and we must use it
 976 initIfaceRules hsc_env guts do_this
 977  = do   { let {
 978              type_info = (mg_module guts, return (mg_types guts))
 979            ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
 980            }
 981
 982         -- Run the thing; any exceptions just bubble out from here
 983         ; initTcRnIf 'i' hsc_env gbl_env () do_this
 984     }
 985
 986 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
 987 initIfaceLcl mod loc_doc thing_inside
 988   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
 989
 990 getIfModule :: IfL Module
 991 getIfModule = do { env <- getLclEnv; return (if_mod env) }
 992
 993 --------------------
 994 failIfM :: Message -> IfL a
 995 -- The Iface monad doesn't have a place to accumulate errors, so we
 996 -- just fall over fast if one happens; it "shouldnt happen".
 997 -- We use IfL here so that we can get context info out of the local env
 998 failIfM msg
 999   = do  { env <- getLclEnv
1000         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1001         ; liftIO (printErrs (full_msg defaultErrStyle))
1002         ; failM }
1003
1004 --------------------
1005 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1006 -- Run thing_inside in an interleaved thread.
1007 -- It shares everything with the parent thread, so this is DANGEROUS.
1008 --
1009 -- It returns Nothing if the computation fails
1010 --
1011 -- It's used for lazily type-checking interface
1012 -- signatures, which is pretty benign
1013
1014 forkM_maybe doc thing_inside
1015  = do { unsafeInterleaveM $
1016         do { traceIf (text "Starting fork {" <+> doc)
1017            ; mb_res <- tryM $
1018                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1019                        thing_inside
1020            ; case mb_res of
1021                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1022                                 ; return (Just r) }
1023                 Left exn -> do {
1024
1025                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1026                     -- Otherwise we silently discard errors. Errors can legitimately
1027                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1028                       ifOptM Opt_D_dump_if_trace
1029                              (print_errs (hang (text "forkM failed:" <+> doc)
1030                                              4 (text (show exn))))
1031
1032                     ; traceIf (text "} ending fork (badly)" <+> doc)
1033                     ; return Nothing }
1034         }}
1035   where
1036     print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1037
1038 forkM :: SDoc -> IfL a -> IfL a
1039 forkM doc thing_inside
1040  = do   { mb_res <- forkM_maybe doc thing_inside
1041         ; return (case mb_res of
1042                         Nothing -> pgmError "Cannot continue after interface file error"
1043                                    -- pprPanic "forkM" doc
1044                         Just r  -> r) }
1045 \end{code}