ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcSimplify]{TcSimplify}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcSimplify (
  10         tcSimplify, tcSimplifyAndCheck,
  11         tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
  12         bindInstsOfLocalFuns
  13     ) where
  14
  15 IMPORT_Trace            -- ToDo: rm (debugging)
  16 import Outputable
  17 import Pretty
  18
  19 import TcMonad          -- typechecking monadic machinery
  20 import TcMonadFns       ( newDicts, applyTcSubstAndExpectTyVars )
  21 import AbsSyn           -- the stuff being typechecked
  22
  23 import AbsUniType       ( isSuperClassOf, getTyVar, eqTyVar, ltTyVar,
  24                           instantiateThetaTy, isFunType, getUniDataTyCon,
  25                           getSuperDictSelId, InstTyEnv(..)
  26                           IF_ATTACK_PRAGMAS(COMMA isTyVarTy COMMA pprUniType)
  27                           IF_ATTACK_PRAGMAS(COMMA assocMaybe)
  28                         )
  29 import UniType          ( UniType(..) ) -- ******* CHEATING ************
  30 import Disambig         ( disambiguateDicts )
  31 import Errors           ( reduceErr, genCantGenErr, Error(..) )
  32 import Id               ( mkInstId )
  33 import Inst             ( extractTyVarsFromInst, isTyVarDict, matchesInst,
  34                           instBindingRequired, instCanBeGeneralised,
  35                           Inst(..),     -- We import the CONCRETE type, because
  36                                         -- TcSimplify is allowed to see the rep
  37                                         -- of Insts
  38                           InstOrigin, OverloadedLit, InstTemplate
  39                         )
  40 import InstEnv
  41 import LIE
  42 import ListSetOps       ( minusList )
  43 import Maybes           ( catMaybes, maybeToBool, Maybe(..) )
  44 import Util
  45 \end{code}
  46
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection[tcSimplify-main]{Main entry function}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 * May modify the substitution to bind ambiguous type variables.
  55
  56 Specification
  57 ~~~~~~~~~~~~~
  58 (1) If an inst constrains only ``global'' type variables, (or none),
  59     return it as a ``global'' inst.
  60
  61 OTHERWISE
  62
  63 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
  64     constraining only a type variable.
  65
  66 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
  67     Otherwise it must be ambiguous, so try to resolve the ambiguity.
  68
  69
  70 \begin{code}
  71 tcSimpl :: Bool                         -- True <=> Don't simplify const insts
  72         -> [TyVar]                      -- ``Global'' type variables
  73         -> [TyVar]                      -- ``Local''  type variables
  74         -> [Inst]                       -- Given; these constrain only local tyvars
  75         -> [Inst]                       -- Wanted
  76         -> TcM ([Inst],                 -- Free
  77                 [(Inst,TypecheckedExpr)],-- Bindings
  78                 [Inst])                 -- Remaining wanteds; no dups
  79
  80 tcSimpl dont_squash_consts global_tvs local_tvs givens wanteds
  81   =
  82          -- Make sure the insts and type variables are fixed points of the substitution
  83     applyTcSubstAndExpectTyVars global_tvs `thenNF_Tc` \ global_tvs ->
  84     applyTcSubstAndExpectTyVars local_tvs  `thenNF_Tc` \ local_tvs ->
  85     applyTcSubstToInsts givens           `thenNF_Tc` \ givens ->
  86     applyTcSubstToInsts wanteds          `thenNF_Tc` \ wanteds ->
  87     let
  88         is_elem1 = isIn "tcSimpl1"
  89         is_elem2 = isIn "tcSimpl2"
  90     in
  91         -- Deal with duplicates and type constructors
  92     elimTyCons
  93          dont_squash_consts (\tv -> tv `is_elem1` global_tvs)
  94          givens wanteds         `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
  95
  96         -- Now disambiguate if necessary
  97     let
  98         (ambigs, unambigs) = partition (is_ambiguous local_tvs) locals_and_ambigs
  99         (locals, cant_generalise) = partition instCanBeGeneralised unambigs
 100     in
 101     checkTc (not (null cant_generalise)) (genCantGenErr cant_generalise)        `thenTc_`
 102
 103     (if (null ambigs) then
 104
 105         -- No ambiguous dictionaries.  Just bash on with the results
 106         -- of the elimTyCons
 107         returnTc (globals, tycon_binds, locals_and_ambigs)
 108
 109     else
 110
 111         -- Some ambiguous dictionaries.  We now disambiguate them,
 112         -- which binds the offending type variables to suitable types in the
 113         -- substitution, and then we retry the whole process.  This
 114         -- time there won't be any ambiguous ones.
 115         -- There's no need to back-substitute on global and local tvs,
 116         -- because the ambiguous type variables can't be in either.
 117
 118         -- Why do we retry the whole process?  Because binding a type variable
 119         -- to a particular type might enable a short-cut simplification which
 120         -- elimTyCons will have missed the first time.
 121
 122         disambiguateDicts ambigs        `thenTc_`
 123         applyTcSubstToInsts givens      `thenNF_Tc` \ givens ->
 124         applyTcSubstToInsts wanteds     `thenNF_Tc` \ wanteds ->
 125         elimTyCons
 126                 dont_squash_consts (\tv -> tv `is_elem2` global_tvs)
 127                 givens wanteds
 128
 129     ) {- End of the "if" -} `thenTc` \ (globals, tycon_binds, locals) ->
 130
 131         -- Deal with superclass relationships
 132     elimSCs givens locals               `thenNF_Tc` \ (sc_binds, locals2) ->
 133
 134          -- Finished
 135     returnTc (globals, sc_binds ++ tycon_binds, locals2)
 136   where
 137     is_ambiguous local_tvs (Dict _ _ ty _)
 138       = getTyVar "is_ambiguous" ty `not_elem` local_tvs
 139       where
 140         not_elem = isn'tIn "is_ambiguous"
 141 \end{code}
 142
 143 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 144 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 145 top level defns we *do* squash constants, so that they stay local to a
 146 single defn.  This makes things which are inlined more likely to be
 147 exportable, because their constants are "inside".  Later passes will
 148 float them out if poss, after inlinings are sorted out.
 149
 150 \begin{code}
 151 tcSimplify
 152         :: Bool                         -- True <=> top level
 153         -> [TyVar]                      -- ``Global'' type variables
 154         -> [TyVar]                      -- ``Local''  type variables
 155         -> [Inst]                       -- Wanted
 156         -> TcM ([Inst],                 -- Free
 157                 [(Inst, TypecheckedExpr)],-- Bindings
 158                 [Inst])                 -- Remaining wanteds; no dups
 159
 160 tcSimplify top_level global_tvs local_tvs wanteds
 161   = tcSimpl (not top_level) global_tvs local_tvs [] wanteds
 162 \end{code}
 163
 164 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 165 that there is an empty wanted-set at the end.
 166
 167 It may still return some of constant insts, which have
 168 to be resolved finally at the end.
 169
 170 \begin{code}
 171 tcSimplifyAndCheck
 172          :: Bool                                -- True <=> top level
 173          -> [TyVar]                             -- ``Global''  type variables
 174          -> [TyVar]                             -- ``Local''  type variables
 175          -> [Inst]                              -- Given
 176          -> [Inst]                              -- Wanted
 177          -> UnifyErrContext                     -- Context info for error
 178          -> TcM ([Inst],                        -- Free
 179                  [(Inst, TypecheckedExpr)])     -- Bindings
 180
 181 tcSimplifyAndCheck top_level global_tvs local_tvs givens wanteds err_ctxt
 182   = tcSimpl (not top_level) global_tvs local_tvs givens wanteds
 183                         `thenTc` \ (free_insts, binds, wanteds') ->
 184     checkTc (not (null wanteds')) (reduceErr wanteds' err_ctxt)
 185                         `thenTc_`
 186     returnTc (free_insts, binds)
 187 \end{code}
 188
 189 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
 190 is not overloaded.
 191
 192 \begin{code}
 193 tcSimplifyRank2 :: [TyVar]              -- ``Local'' type variables; guaranteed fixpoint of subst
 194                 -> [Inst]               -- Given
 195                 -> UnifyErrContext
 196                 -> TcM ([Inst],                         -- Free
 197                         [(Inst, TypecheckedExpr)])      -- Bindings
 198
 199 tcSimplifyRank2 local_tvs givens err_ctxt
 200   = applyTcSubstToInsts givens           `thenNF_Tc` \ givens' ->
 201     elimTyCons False
 202                (\tv -> not (tv `is_elem` local_tvs))
 203                 -- This predicate claims that all
 204                 -- any non-local tyvars are global,
 205                 -- thereby postponing dealing with
 206                 -- ambiguity until the enclosing Gen
 207                [] givens'       `thenTc` \ (free, dict_binds, wanteds) ->
 208
 209     checkTc (not (null wanteds)) (reduceErr wanteds err_ctxt)   `thenTc_`
 210
 211     returnTc (free, dict_binds)
 212   where
 213     is_elem = isIn "tcSimplifyRank2"
 214 \end{code}
 215
 216 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
 217 mechansim with the extra flag to say ``beat out constant insts''.
 218
 219 \begin{code}
 220 tcSimplifyTop :: [Inst] -> TcM [(Inst, TypecheckedExpr)]
 221 tcSimplifyTop dicts
 222   = tcSimpl False [] [] [] dicts    `thenTc` \ (_, binds, _) ->
 223     returnTc binds
 224 \end{code}
 225
 226 @tcSimplifyThetas@ simplifies class-type constraints formed by
 227 @deriving@ declarations and when specialising instances.  We are
 228 only interested in the simplified bunch of class/type constraints.
 229
 230 \begin{code}
 231 tcSimplifyThetas :: (Class -> TauType -> InstOrigin)  -- Creates an origin for the dummy dicts
 232                  -> [(Class, TauType)]                -- Simplify this
 233                  -> TcM [(Class, TauType)]            -- Result
 234
 235 tcSimplifyThetas mk_inst_origin theta
 236   = let
 237         dicts = map mk_dummy_dict theta
 238     in
 239          -- Do the business (this is just the heart of "tcSimpl")
 240     elimTyCons False (\tv -> False) [] dicts    `thenTc`        \ (_, _, dicts2) ->
 241
 242           -- Deal with superclass relationships
 243     elimSCs [] dicts2               `thenNF_Tc` \ (_, dicts3) ->
 244
 245     returnTc (map unmk_dummy_dict dicts3)
 246   where
 247     mk_dummy_dict (clas, ty)
 248       = Dict uniq clas ty (mk_inst_origin clas ty)
 249
 250     uniq = panic "tcSimplifyThetas:uniq"
 251
 252     unmk_dummy_dict (Dict _ clas ty _) = (clas, ty)
 253 \end{code}
 254
 255 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 256 used with \tr{default} declarations.  We are only interested in
 257 whether it worked or not.
 258
 259 \begin{code}
 260 tcSimplifyCheckThetas :: InstOrigin             -- context; for error msg
 261                 -> [(Class, TauType)]   -- Simplify this
 262                 -> TcM ()
 263
 264 tcSimplifyCheckThetas origin theta
 265   = let
 266         dicts = map mk_dummy_dict theta
 267     in
 268          -- Do the business (this is just the heart of "tcSimpl")
 269     elimTyCons False (\tv -> False) [] dicts    `thenTc`        \ _ ->
 270
 271     returnTc ()
 272   where
 273     mk_dummy_dict (clas, ty)
 274       = Dict uniq clas ty origin
 275
 276     uniq = panic "tcSimplifyCheckThetas:uniq"
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection[elimTyCons]{@elimTyCons@}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 elimTyCons :: Bool                              -- True <=> Don't simplify const insts
 288            -> (TyVar -> Bool)                   -- Free tyvar predicate
 289            -> [Inst]                            -- Given
 290            -> [Inst]                            -- Wanted
 291            -> TcM ([Inst],                      -- Free
 292                    [(Inst, TypecheckedExpr)],   -- Bindings
 293                    [Inst]                       -- Remaining wanteds; no dups;
 294                                                 -- dicts only (no Methods)
 295                )
 296 \end{code}
 297
 298 The bindings returned may mention any or all of ``givens'', so the
 299 order in which the generated binds are put together is {\em tricky}.
 300 Case~4 of @try@ is the general case to see.
 301
 302 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
 303
 304     (1) first look up @wanted@; this gives us one binding to heave in:
 305             wanted = rhs
 306
 307     (2) step (1) also gave us some @simpler_wanteds@; we simplify
 308         these and get some (simpler-wanted-)bindings {\em that must be
 309         in scope} for the @wanted=rhs@ binding above!
 310
 311     (3) we simplify the remaining @wanteds@ (recursive call), giving
 312         us yet more bindings.
 313
 314 The final arrangement of the {\em non-recursive} bindings is
 315
 316     let <simpler-wanted-binds> in
 317     let wanted = rhs           in
 318     let <yet-more-bindings> ...
 319
 320 \begin{code}
 321 elimTyCons dont_squash_consts is_free_tv givens wanteds
 322   = eTC givens wanteds
 323   where
 324     eTC :: [Inst] -> [Inst]
 325         -> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst])
 326
 327     eTC _ [] = returnTc ([], [], [])
 328
 329     eTC givens (wanted:wanteds) = try givens wanted wanteds
 330                                       (extractTyVarsFromInst wanted)
 331                                       (find_equiv givens wanted)
 332         -- find_equiv looks in "givens" for an inst equivalent to "wanted"
 333         -- This is used only in Case 2 below; it's like a guard which also
 334         -- returns a result.
 335
 336     try :: [Inst] -> Inst -> [Inst] -> [TyVar] -> (Maybe Inst)
 337         -> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst])
 338
 339     -- Case 0: same as existing dict, so build a simple binding
 340     try givens wanted wanteds tvs_of_wanted (Just this)
 341      = eTC givens wanteds       `thenTc` \ (frees, binds, wanteds') ->
 342        let
 343           -- Create a new binding iff it's needed
 344           new_binds | instBindingRequired wanted = (wanted, Var (mkInstId this)):binds
 345                     | otherwise                  = binds
 346        in
 347        returnTc (frees, new_binds, wanteds')
 348
 349     -- Case 1: constrains no type variables at all
 350     -- In this case we have a quick go to see if it has an
 351     -- instance which requires no inputs (ie a constant); if so we use
 352     -- it; if not, we give up on the instance and just heave it out the
 353     -- top in the free result
 354     try givens wanted wanteds tvs_of_wanted _ | null tvs_of_wanted
 355       = simplify_it dont_squash_consts {- If dont_squash_consts is true,
 356                                           simplify only if trival -}
 357                     givens wanted wanteds
 358
 359     -- Case 2: constrains free vars only, so fling it out the top in free_ids
 360     try givens wanted wanteds tvs_of_wanted _
 361       | all is_free_tv tvs_of_wanted
 362       = eTC (wanted:givens) wanteds     `thenTc` \ (frees, binds, wanteds') ->
 363         returnTc (wanted:frees, binds, wanteds')
 364
 365     -- Case 3: is a dict constraining only a tyvar,
 366     -- so return it as part of the "wanteds" result
 367     try givens wanted wanteds tvs_of_wanted _
 368       | isTyVarDict wanted
 369       = eTC (wanted:givens) wanteds     `thenTc` \ (frees, binds, wanteds') ->
 370         returnTc (frees, binds, wanted:wanteds')
 371
 372     -- Case 4: is not a simple dict, so look up in instance environment
 373     try givens wanted wanteds tvs_of_wanted _
 374       = simplify_it False {- Simplify even if not trivial -}
 375                     givens wanted wanteds
 376
 377     simplify_it only_if_trivial givens wanted wanteds
 378       = if not (instBindingRequired wanted) then
 379                 -- No binding required for this chap, so squash right away
 380            lookupNoBindInst_Tc wanted   `thenTc` \ simpler_wanteds ->
 381
 382            eTC givens simpler_wanteds   `thenTc` \ (frees1, binds1, wanteds1) ->
 383            let
 384                new_givens = [new_given | (new_given,rhs) <- binds1]
 385                 -- Typically binds1 is empty
 386            in
 387            eTC givens wanteds           `thenTc` \ (frees2, binds2, wanteds2) ->
 388
 389            returnTc (frees1 ++ frees2,
 390                      binds1 ++ binds2,
 391                      wanteds1 ++ wanteds2)
 392
 393         else    -- An binding is required for this inst
 394         lookupInst_Tc wanted    `thenTc` \ (rhs, simpler_wanteds) ->
 395
 396         if (only_if_trivial && not_var rhs) then
 397            -- Ho ho!  It isn't trivial to simplify "wanted",
 398            -- because the rhs isn't a simple variable.  The flag
 399            -- dont_squash_consts tells us to give up now and
 400            -- just fling it out the top.
 401            eTC (wanted:givens) wanteds  `thenTc` \ (frees, binds, wanteds') ->
 402            returnTc (wanted:frees, binds, wanteds')
 403         else
 404            -- Aha! Either it's easy, or dont_squash_consts is
 405            -- False, so we must do it right here.
 406
 407            eTC givens simpler_wanteds   `thenTc` \ (frees1, binds1, wanteds1) ->
 408            let
 409                new_givens = [new_given | (new_given,rhs) <- binds1]
 410            in
 411            eTC (new_givens ++ [wanted] ++ wanteds1 ++ givens) wanteds
 412                                    `thenTc` \ (frees2, binds2, wanteds2) ->
 413            returnTc (frees1 ++ frees2,
 414                      binds1 ++ [(wanted, rhs)] ++ binds2,
 415                      wanteds1 ++ wanteds2)
 416       where
 417         not_var :: TypecheckedExpr -> Bool
 418         not_var (Var _) = False
 419         not_var other   = True
 420
 421     find_equiv :: [Inst] -> Inst -> Maybe Inst
 422         -- Look through the argument list for an inst which is
 423         -- equivalent to the second arg.
 424
 425     find_equiv []             wanted = Nothing
 426     find_equiv (given:givens) wanted
 427       | wanted `matchesInst` given = Just given
 428       | otherwise                  = find_equiv givens wanted
 429 \end{code}
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsection[elimSCs]{@elimSCs@}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 elimSCs :: [Inst]                               -- Given; no dups
 440         -> [Inst]                               -- Wanted; no dups; all dictionaries, all
 441                                                 -- constraining just a type variable
 442         -> NF_TcM ([(Inst,TypecheckedExpr)],    -- Bindings
 443                    [Inst])                      -- Minimal wanted set
 444
 445 elimSCs givens wanteds
 446   = -- Sort the wanteds so that subclasses occur before superclasses
 447     elimSCs_help
 448         [dict | dict@(Dict _ _ _ _) <- givens]  -- Filter out non-dictionaries
 449         (sortSC wanteds)
 450
 451 elimSCs_help :: [Inst]                          -- Given; no dups
 452              -> [Inst]                          -- Wanted; no dups;
 453              -> NF_TcM ([(Inst,TypecheckedExpr)],-- Bindings
 454                         [Inst])                 -- Minimal wanted set
 455
 456 elimSCs_help given [] = returnNF_Tc ([], [])
 457
 458 elimSCs_help givens (wanted@(Dict _ wanted_class wanted_ty wanted_orig):wanteds)
 459   = case (trySC givens wanted_class wanted_ty) of
 460
 461       Nothing -> -- No superclass relnship found
 462                  elimSCs_help (wanted:givens) wanteds `thenNF_Tc` \ (binds, wanteds') ->
 463                  returnNF_Tc (binds, wanted:wanteds')
 464
 465       Just (given, classes) ->  -- Aha! There's a superclass relnship
 466
 467         -- Build intermediate dictionaries
 468         let
 469             theta = [ (clas, wanted_ty) | clas <- classes ]
 470         in
 471         newDicts wanted_orig theta              `thenNF_Tc` \ intermediates ->
 472
 473         -- Deal with the recursive call
 474         elimSCs_help (wanted : (intermediates ++ givens)) wanteds
 475                                                 `thenNF_Tc` \ (binds, wanteds') ->
 476
 477         -- Create bindings for the wanted dictionary and the intermediates.
 478         -- Later binds may depend on earlier ones, so each new binding is pushed
 479         -- on the front of the accumulating parameter list of bindings
 480         let
 481             new_binds = mk_binds wanted wanted_class (intermediates ++ [given]) []
 482         in
 483         returnNF_Tc (new_binds ++ binds, wanteds')
 484   where
 485     mk_binds :: Inst                            -- Define this
 486              -> Class                           -- ...whose class is this
 487              -> [Inst]                          -- In terms of this sub-class chain
 488              -> [(Inst, TypecheckedExpr)]       -- Push the binding on front of these
 489              -> [(Inst, TypecheckedExpr)]
 490
 491     mk_binds dict clas [] binds_so_far = binds_so_far
 492     mk_binds dict clas (dict_sub@(Dict _ dict_sub_class ty _):dicts_sub) binds_so_far
 493       = mk_binds dict_sub dict_sub_class dicts_sub (new_bind:binds_so_far)
 494       where
 495         new_bind = (dict, DictApp (TyApp (Var (getSuperDictSelId dict_sub_class clas))
 496                                          [ty])
 497                                   [mkInstId dict_sub])
 498
 499
 500 trySC :: [Inst]                         -- Givens
 501       -> Class -> UniType               -- Wanted
 502       -> Maybe (Inst, [Class])          -- Nothing if no link; Just (given, classes)
 503                                         -- if wanted can be given in terms of given, with
 504                                         -- intermediate classes specified
 505 trySC givens wanted_class wanted_ty
 506   = case subclass_relns of
 507          [] -> Nothing
 508          ((given, classes, _): _) -> Just (given, classes)
 509   where
 510     subclass_relns :: [(Inst, [Class], Int)]    -- Subclass of wanted,
 511                                                  -- intervening classes,
 512                                                  -- and number of intervening classes
 513                                                  -- Sorted with shortest link first
 514     subclass_relns = sortLt reln_lt (catMaybes (map find_subclass_reln givens))
 515
 516     reln_lt :: (Inst, [Class], Int) -> (Inst, [Class], Int) -> Bool
 517     (_,_,n1) `reln_lt` (_,_,n2) = n1 < n2
 518
 519     find_subclass_reln given@(Dict _ given_class given_ty _)
 520          | wanted_ty == given_ty
 521          = case (wanted_class `isSuperClassOf` given_class) of
 522
 523                  Just classes -> Just (given,
 524                                        classes,
 525                                        length classes)
 526
 527                  Nothing      -> Nothing
 528
 529          | otherwise = Nothing
 530
 531
 532 sortSC :: [Inst]    -- Expected to be all dicts (no MethodIds), all of
 533                     -- which constrain type variables
 534        -> [Inst]    -- Sorted with subclasses before superclasses
 535
 536 sortSC dicts = sortLt lt dicts
 537   where
 538     (Dict _ c1 ty1 _) `lt` (Dict _ c2 ty2 _)
 539        = tv1 `ltTyVar` tv2 ||
 540         (tv1 `eqTyVar` tv2 && maybeToBool (c2 `isSuperClassOf` c1))
 541        where
 542         tv1 = getTyVar "sortSC" ty1
 543         tv2 = getTyVar "sortSC" ty2
 544 \end{code}
 545
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 When doing a binding group, we may have @Insts@ of local functions.
 554 For example, we might have...
 555 \begin{verbatim}
 556 let f x = x + 1     -- orig local function (overloaded)
 557     f.1 = f Int     -- two instances of f
 558     f.2 = f Float
 559  in
 560     (f.1 5, f.2 6.7)
 561 \end{verbatim}
 562 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 563 where @f@ is in scope; those @Insts@ must certainly not be passed
 564 upwards towards the top-level.  If the @Insts@ were binding-ified up
 565 there, they would have unresolvable references to @f@.
 566
 567 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 568 For each method @Inst@ in the @init_lie@ that mentions one of the
 569 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 570 @LIE@), as well as the @Binds@ generated.
 571
 572 \begin{code}
 573 bindInstsOfLocalFuns :: LIE -> [Id] -> NF_TcM (LIE, TypecheckedMonoBinds)
 574
 575 bindInstsOfLocalFuns init_lie local_ids
 576   = let
 577         insts = unMkLIE init_lie
 578     in
 579     bind_insts insts [] EmptyMonoBinds
 580   where
 581     bind_insts  :: [Inst]               -- Insts to mangle
 582                 -> [Inst]               -- accum. Insts to return
 583                 -> TypecheckedMonoBinds -- accum. Binds to return
 584                 -> NF_TcM (LIE, TypecheckedMonoBinds)
 585
 586     bind_insts [] acc_insts acc_binds
 587       = returnNF_Tc (mkLIE acc_insts, acc_binds)
 588
 589     bind_insts (inst@(Method uniq id tys orig):insts) acc_insts acc_binds
 590       | id `is_elem` local_ids
 591       = noFailTc (lookupInst_Tc inst)   `thenNF_Tc` \ (expr, dict_insts) ->
 592         let
 593             bind =  VarMonoBind (mkInstId inst) expr
 594         in
 595         bind_insts insts (dict_insts ++ acc_insts) (bind `AndMonoBinds` acc_binds)
 596
 597     bind_insts (some_other_inst:insts) acc_insts acc_binds
 598         -- Either not a method, or a method instance for an id not in local_ids
 599       = bind_insts insts (some_other_inst:acc_insts) acc_binds
 600
 601     is_elem = isIn "bindInstsOfLocalFuns"
 602 \end{code}