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