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