ghc/compiler/rename/RnMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnMonad]{The monad used by the renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnMonad (
  10         RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
  11         initRn, thenRn, thenRn_, andRn, returnRn,
  12         mapRn, mapAndUnzipRn,
  13
  14         addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
  15         failButContinueRn, warnAndContinueRn,
  16         setExtraRn, getExtraRn,
  17         getModuleRn, pushSrcLocRn, getSrcLocRn,
  18         getSourceRn, getOccurrenceUpRn,
  19         getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv,
  20         rnGetUnique, rnGetUniques,
  21
  22         newLocalNames,
  23         lookupValue, lookupValueMaybe, lookupClassOp,
  24         lookupTyCon, lookupClass, lookupTyConOrClass,
  25         extendSS2, extendSS,
  26
  27         TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
  28         lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
  29
  30         fixIO
  31     ) where
  32
  33 import Ubiq{-uitous-}
  34
  35 import SST
  36
  37 import HsSyn            ( FixityDecl )
  38 import RnHsSyn          ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
  39                           mkRnImplicitTyCon, mkRnImplicitClass,
  40                           isRnLocal, isRnWired, isRnTyCon, isRnClass,
  41                           isRnTyConOrClass, isRnClassOp,
  42                           RenamedFixityDecl(..) )
  43 import RnUtils          ( RnEnv(..), extendLocalRnEnv,
  44                           lookupRnEnv, lookupTcRnEnv,
  45                           unknownNameErr, badClassOpErr, qualNameErr,
  46                           dupNamesErr, shadowedNameWarn )
  47
  48 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag )
  49 import CmdLineOpts      ( opt_WarnNameShadowing )
  50 import ErrUtils         ( Error(..), Warning(..) )
  51 import FiniteMap        ( FiniteMap, emptyFM, lookupFM, addToFM )
  52 import Maybes           ( assocMaybe )
  53 import Name             ( Module(..), RdrName(..), isQual,
  54                           Name, mkLocalName, mkImplicitName,
  55                           getOccName
  56                         )
  57 import PrelInfo         ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
  58 import Pretty           ( Pretty(..), PrettyRep )
  59 import SrcLoc           ( SrcLoc, mkUnknownSrcLoc )
  60 import UniqFM           ( UniqFM, emptyUFM )
  61 import UniqSet          ( UniqSet(..), mkUniqSet, minusUniqSet )
  62 import UniqSupply       ( UniqSupply, getUnique, getUniques, splitUniqSupply )
  63 import Unique           ( Unique )
  64 import Util
  65
  66 infixr 9 `thenRn`, `thenRn_`
  67 \end{code}
  68
  69 \begin{code}
  70 type RnM s r       = RnMonad () s r
  71 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
  72
  73 type RnMonad x s r = RnDown x s -> SST s r
  74
  75 data RnDown x s
  76   = RnDown
  77         x
  78         Module                          -- Module name
  79         SrcLoc                          -- Source location
  80         (RnMode s)                      -- Source or Iface
  81         RnEnv                           -- Renaming environment
  82         (MutableVar s UniqSupply)       -- Unique supply
  83         (MutableVar s (Bag Warning,     -- Warnings and Errors
  84                        Bag Error))
  85
  86 data RnMode s
  87  = RnSource (MutableVar s (Bag (RnName, RdrName)))
  88         -- Renaming source; returning occurences
  89
  90  | RnIface  BuiltinNames BuiltinKeys
  91             (MutableVar s ImplicitEnv)
  92         -- Renaming interface; creating and returning implicit names
  93         -- ImplicitEnv: one map for Values and one for TyCons/Classes.
  94
  95 type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
  96 emptyImplicitEnv :: ImplicitEnv
  97 emptyImplicitEnv = (emptyFM, emptyFM)
  98
  99 -- With a builtin polymorphic type for _runSST the type for
 100 -- initTc should use  RnM s r  instead of  RnM _RealWorld r
 101
 102 initRn :: Bool          -- True => Source; False => Iface
 103        -> Module
 104        -> RnEnv
 105        -> UniqSupply
 106        -> RnM _RealWorld r
 107        -> (r, Bag Error, Bag Warning)
 108
 109 initRn source mod env us do_rn
 110   = _runSST (
 111         newMutVarSST emptyBag                   `thenSST` \ occ_var ->
 112         newMutVarSST emptyImplicitEnv           `thenSST` \ imp_var ->
 113         newMutVarSST us                         `thenSST` \ us_var ->
 114         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ errs_var ->
 115         let
 116             mode = if source then
 117                        RnSource occ_var
 118                    else
 119                        case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
 120                        RnIface wiredin_fm key_fm imp_var }
 121
 122             rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 123         in
 124         -- do the buisness
 125         do_rn rn_down                           `thenSST` \ res ->
 126
 127         -- grab errors and return
 128         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 129         returnSST (res, errs, warns)
 130     )
 131
 132 {-# INLINE thenRn #-}
 133 {-# INLINE thenRn_ #-}
 134 {-# INLINE returnRn #-}
 135 {-# INLINE andRn #-}
 136
 137 returnRn :: a -> RnMonad x s a
 138 thenRn   :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
 139 thenRn_  :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
 140 andRn    :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
 141 mapRn    :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
 142 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
 143
 144 returnRn v down  = returnSST v
 145 thenRn m k down  = m down `thenSST` \ r -> k r down
 146 thenRn_ m k down = m down `thenSST_` k down
 147
 148 andRn combiner m1 m2 down
 149   = m1 down `thenSST` \ res1 ->
 150     m2 down `thenSST` \ res2 ->
 151     returnSST (combiner res1 res2)
 152
 153 mapRn f []     = returnRn []
 154 mapRn f (x:xs)
 155   = f x         `thenRn` \ r ->
 156     mapRn f xs  `thenRn` \ rs ->
 157     returnRn (r:rs)
 158
 159 mapAndUnzipRn f [] = returnRn ([],[])
 160 mapAndUnzipRn f (x:xs)
 161   = f x                 `thenRn` \ (r1,  r2)  ->
 162     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 163     returnRn (r1:rs1, r2:rs2)
 164 \end{code}
 165
 166 For errors and warnings ...
 167 \begin{code}
 168 failButContinueRn :: a -> Error -> RnMonad x s a
 169 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
 170   = readMutVarSST  errs_var                             `thenSST`  \ (warns,errs) ->
 171     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 172     returnSST res
 173
 174 warnAndContinueRn :: a -> Warning -> RnMonad x s a
 175 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
 176   = readMutVarSST  errs_var                              `thenSST`  \ (warns,errs) ->
 177     writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
 178     returnSST res
 179
 180 addErrRn :: Error -> RnMonad x s ()
 181 addErrRn err = failButContinueRn () err
 182
 183 addErrIfRn :: Bool -> Error -> RnMonad x s ()
 184 addErrIfRn True err  = addErrRn err
 185 addErrIfRn False err = returnRn ()
 186
 187 addWarnRn :: Warning -> RnMonad x s ()
 188 addWarnRn warn = warnAndContinueRn () warn
 189
 190 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
 191 addWarnIfRn True warn  = addWarnRn warn
 192 addWarnIfRn False warn = returnRn ()
 193 \end{code}
 194
 195
 196 \begin{code}
 197 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
 198 setExtraRn x m (RnDown _ mod locn mode env us errs)
 199   = m (RnDown x mod locn mode env us errs)
 200
 201 getExtraRn :: RnMonad x s x
 202 getExtraRn (RnDown x _ _ _ _ _ _)
 203   = returnSST x
 204
 205 getModuleRn :: RnMonad x s Module
 206 getModuleRn (RnDown _ mod _ _ _ _ _)
 207   = returnSST mod
 208
 209 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
 210 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
 211   = m (RnDown x mod locn mode env us errs)
 212
 213 getSrcLocRn :: RnMonad x s SrcLoc
 214 getSrcLocRn (RnDown _ _ locn _ _ _ _)
 215   = returnSST locn
 216
 217 getSourceRn :: RnMonad x s Bool
 218 getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
 219 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
 220
 221 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
 222 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
 223   = readMutVarSST occ_var
 224 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
 225   = panic "getOccurrenceUpRn:RnIface"
 226
 227 getImplicitUpRn :: RnMonad x s ImplicitEnv
 228 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
 229   = readMutVarSST imp_var
 230 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
 231   = panic "getImplicitUpRn:RnIface"
 232 \end{code}
 233
 234 \begin{code}
 235 rnGetUnique :: RnMonad x s Unique
 236 rnGetUnique (RnDown _ _ _ _ _ us_var _)
 237   = get_unique us_var
 238
 239 rnGetUniques :: Int -> RnMonad x s [Unique]
 240 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
 241   = get_uniques n us_var
 242
 243
 244 get_unique us_var
 245   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 246     let
 247       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 248       uniq                      = getUnique uniq_s
 249     in
 250     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 251     returnSST uniq
 252
 253 get_uniques n us_var
 254   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 255     let
 256       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 257       uniqs                     = getUniques n uniq_s
 258     in
 259     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 260     returnSST uniqs
 261
 262 snoc_bag_var add bag_var
 263   = readMutVarSST bag_var       `thenSST` \ bag ->
 264     writeMutVarSST bag_var (bag `snocBag` add)
 265
 266 \end{code}
 267
 268 *********************************************************
 269 *                                                       *
 270 \subsection{Making new names}
 271 *                                                       *
 272 *********************************************************
 273
 274 @newLocalNames@ takes a bunch of RdrNames, which are defined together
 275 in a group (eg a pattern or set of bindings), checks they are
 276 unqualified and distinct, and creates new Names for them.
 277
 278 \begin{code}
 279 newLocalNames :: String                 -- Documentation string
 280               -> [(RdrName, SrcLoc)]
 281               -> RnMonad x s [RnName]
 282
 283 newLocalNames str names_w_loc
 284   = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
 285     mapRn (addErrRn . dupNamesErr str) dups  `thenRn_`
 286     mkLocalNames these
 287   where
 288     quals         = filter (isQual.fst) names_w_loc
 289     (these, dups) = removeDups cmp_fst names_w_loc
 290     cmp_fst (a,_) (b,_) = cmp a b
 291 \end{code}
 292
 293 \begin{code}
 294 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
 295 mkLocalNames names_w_locs
 296   = rnGetUniques (length names_w_locs)  `thenRn` \ uniqs ->
 297     returnRn (zipWithEqual new_local uniqs names_w_locs)
 298   where
 299     new_local uniq (Unqual str, srcloc)
 300       = mkRnName (mkLocalName uniq str srcloc)
 301 \end{code}
 302
 303
 304 *********************************************************
 305 *                                                       *
 306 \subsection{Looking up values}
 307 *                                                       *
 308 *********************************************************
 309
 310 Action to look up a value depends on the RnMode.
 311 \begin{description}
 312 \item[RnSource:]
 313 Lookup value in RnEnv, recording occurrence for non-local values found.
 314 If not found report error and return Unbound name.
 315 \item[RnIface:]
 316 Lookup value in RnEnv. If not found lookup in implicit name env.
 317 If not found create new implicit name, adding it to the implicit env.
 318 \end{description}
 319
 320 \begin{code}
 321 lookupValue      :: RdrName -> RnMonad x s RnName
 322 lookupClassOp    :: RnName  -> RdrName -> RnMonad x s RnName
 323
 324 lookupValue rdr
 325   = lookup_val rdr (\ rn -> True) (unknownNameErr "value")
 326
 327 lookupClassOp cls rdr
 328   = lookup_val rdr (\ rn -> True){-WAS:(isRnClassOp cls)-} (badClassOpErr cls)
 329
 330
 331 lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 332   = case lookupRnEnv env rdr of
 333         Just name | check name -> succ name
 334                   | otherwise  -> fail
 335         Nothing                -> fail
 336
 337   where
 338     succ name = if isRnLocal name || isRnWired name then
 339                     returnSST name
 340                 else
 341                     snoc_bag_var (name,rdr) occ_var `thenSST_`
 342                     returnSST name
 343     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 344
 345 lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
 346   = case lookupRnEnv env rdr of
 347         Just name | check name -> returnSST name
 348                   | otherwise  -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 349         Nothing                -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
 350
 351 lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr
 352   = case rdr of
 353       Qual _ _ -> -- builtin things *don't* have Qual names
 354                   lookup_or_create_implicit_val b_key imp_var us_var rdr
 355
 356       Unqual n -> case (lookupFM b_names n) of
 357                     Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr
 358                     Just xx -> returnSST xx
 359
 360 lookup_or_create_implicit_val b_key imp_var us_var rdr
 361   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
 362     case lookupFM implicit_val_fm rdr of
 363         Just implicit -> returnSST implicit
 364         Nothing ->
 365           (case rdr of
 366              Qual _ _ -> get_unique us_var
 367              Unqual n -> case (lookupFM b_key n) of
 368                            Just (u,_) -> returnSST u
 369                            _          -> get_unique us_var
 370           )                                     `thenSST` \ uniq ->
 371           let
 372               implicit   = mkRnImplicit (mkImplicitName uniq rdr)
 373               new_val_fm = addToFM implicit_val_fm rdr implicit
 374           in
 375           writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
 376           returnSST implicit
 377
 378
 379 lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName)
 380 lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _)
 381   = returnSST (lookupRnEnv env rdr)
 382 \end{code}
 383
 384
 385 \begin{code}
 386 lookupTyCon   :: RdrName -> RnMonad x s RnName
 387 lookupClass   :: RdrName -> RnMonad x s RnName
 388
 389 lookupTyCon rdr
 390   = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
 391
 392 lookupClass rdr
 393   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 394
 395 lookupTyConOrClass rdr
 396   = lookup_tc rdr isRnTyConOrClass
 397               (panic "lookupTC:mk_implicit") "class or type constructor"
 398
 399 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 400   = case lookupTcRnEnv env rdr of
 401        Just name | check name -> succ name
 402                  | otherwise  -> fail
 403        Nothing                -> fail
 404   where
 405     succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
 406                 returnSST name
 407     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 408
 409 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
 410   = case lookupTcRnEnv env rdr of
 411         Just name | check name -> returnSST name
 412                   | otherwise  -> fail
 413         Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr
 414   where
 415     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 416
 417 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
 418   = case rdr of
 419       Qual _ _ -> -- builtin things *don't* have Qual names
 420                   lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
 421
 422       Unqual n -> case (lookupFM b_names n) of
 423                     Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
 424                     Just xx -> returnSST xx
 425
 426 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
 427   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
 428     case lookupFM implicit_tc_fm rdr of
 429         Just implicit | check implicit -> returnSST implicit
 430                       | otherwise      -> fail
 431         Nothing ->
 432           (case rdr of
 433              Qual _ _ -> get_unique us_var
 434              Unqual n -> case (lookupFM b_key n) of
 435                            Just (u,_) -> returnSST u
 436                            _          -> get_unique us_var
 437           )                                     `thenSST` \ uniq ->
 438           let
 439               implicit  = mk_implicit (mkImplicitName uniq rdr)
 440               new_tc_fm = addToFM implicit_tc_fm rdr implicit
 441           in
 442           writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
 443           returnSST implicit
 444 \end{code}
 445
 446
 447 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
 448 free vars from the result.
 449
 450 \begin{code}
 451 extendSS :: [RnName]                            -- Newly bound names
 452          -> RnMonad x s a
 453          -> RnMonad x s a
 454
 455 extendSS binders m down@(RnDown x mod locn mode env us errs)
 456   = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
 457      m) (RnDown x mod locn mode new_env us errs)
 458   where
 459     (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
 460
 461 extendSS2 :: [RnName]                           -- Newly bound names
 462           -> RnMonad x s (a, UniqSet RnName)
 463           -> RnMonad x s (a, UniqSet RnName)
 464
 465 extendSS2 binders m
 466   = extendSS binders m `thenRn` \ (r, fvs) ->
 467     returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
 468 \end{code}
 469
 470 The free var set returned by @(extendSS binders m)@ is that returned
 471 by @m@, {\em minus} binders.
 472
 473
 474 *********************************************************
 475 *                                                       *
 476 \subsection{TyVarNamesEnv}
 477 *                                                       *
 478 *********************************************************
 479
 480 \begin{code}
 481 type TyVarNamesEnv = [(RdrName, RnName)]
 482
 483 nullTyVarNamesEnv :: TyVarNamesEnv
 484 nullTyVarNamesEnv = []
 485
 486 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
 487 catTyVarNamesEnvs e1 e2 = e1 ++ e2
 488
 489 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
 490 domTyVarNamesEnv env = map fst env
 491 \end{code}
 492
 493 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
 494
 495 \begin{code}
 496 mkTyVarNamesEnv
 497         :: SrcLoc
 498         -> [RdrName]                            -- The type variables
 499         -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
 500
 501 mkTyVarNamesEnv src_loc tyvars
 502   = newLocalNames "type variable"
 503          (tyvars `zip` repeat src_loc) `thenRn`  \ rn_tyvars ->
 504
 505          -- rn_tyvars may not be in the same order as tyvars, so we need some
 506          -- jiggery pokery to build the right tyvar env, and return the
 507          -- renamed tyvars in the original order.
 508     let tv_occ_name_pairs       = map tv_occ_name_pair rn_tyvars
 509         tv_env                  = map (lookup_occ_name tv_occ_name_pairs) tyvars
 510         rn_tyvars_in_orig_order = map snd tv_env
 511     in
 512     returnRn (tv_env, rn_tyvars_in_orig_order)
 513   where
 514     tv_occ_name_pair :: RnName -> (RdrName, RnName)
 515     tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
 516
 517     lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
 518     lookup_occ_name pairs tyvar_occ
 519       = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
 520 \end{code}
 521
 522 \begin{code}
 523 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
 524 lookupTyVarName env occ
 525   = case (assocMaybe env occ) of
 526       Just name -> returnRn name
 527       Nothing   -> getSrcLocRn  `thenRn` \ loc ->
 528                    failButContinueRn (mkRnUnbound occ)
 529                        (unknownNameErr "type variable" occ loc)
 530 \end{code}
 531
 532
 533 \begin{code}
 534 fixIO :: (a -> IO a) -> IO a
 535 fixIO k s = let
 536                 result          = k loop s
 537                 (Right loop, _) = result
 538             in
 539             result
 540 \end{code}