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