ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 IMP_Ubiq()
  16
  17 import HsSyn            ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
  18                           Match, HsBinds, HsType, ArithSeqInfo, Fixity,
  19                           GRHSsAndBinds, Stmt, DoOrListComp, Fake )
  20 import HsBinds          ( andMonoBinds )
  21 import TcHsSyn          ( SYN_IE(TcExpr), SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )
  22
  23 import TcMonad
  24 import Inst             ( lookupInst, lookupSimpleInst,
  25                           tyVarsOfInst, isTyVarDict, isDict,
  26                           matchesInst, instToId, instBindingRequired,
  27                           instCanBeGeneralised, newDictsAtLoc,
  28                           pprInst,
  29                           Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, pprLIE, pprLIEInFull,
  30                           plusLIE, unitLIE, consLIE, InstOrigin(..),
  31                           OverloadedLit )
  32 import TcEnv            ( tcGetGlobalTyVars )
  33 import SpecEnv          ( SpecEnv )
  34 import TcType           ( TcIdOcc(..), SYN_IE(TcIdBndr),
  35                           SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType
  36                         )
  37 import Unify            ( unifyTauTy )
  38
  39 import Bag              ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
  40                           snocBag, consBag, unionBags, isEmptyBag )
  41 import Class            ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
  42                           isSuperClassOf, classSuperDictSelId, classInstEnv
  43                         )
  44 import Id               ( GenId )
  45 import PrelInfo         ( isNumericClass, isStandardClass, isCcallishClass )
  46
  47 import Maybes           ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
  48 import Outputable       ( PprStyle, Outputable(..){-instance * []-} )
  49 import PprType          ( GenType, GenTyVar )
  50 import Pretty
  51 import SrcLoc           ( noSrcLoc )
  52 import Type             ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
  53                           getTyVar_maybe )
  54 import TysWiredIn       ( intTy, unitTy )
  55 import TyVar            ( GenTyVar, SYN_IE(GenTyVarSet),
  56                           elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
  57                           isEmptyTyVarSet, tyVarSetToList )
  58 import Unique           ( Unique )
  59 import Util
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection[tcSimplify-main]{Main entry function}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 * May modify the substitution to bind ambiguous type variables.
  70
  71 Specification
  72 ~~~~~~~~~~~~~
  73 (1) If an inst constrains only ``global'' type variables, (or none),
  74     return it as a ``global'' inst.
  75
  76 OTHERWISE
  77
  78 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
  79     constraining only a type variable.
  80
  81 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
  82     Otherwise it must be ambiguous, so try to resolve the ambiguity.
  83
  84
  85 \begin{code}
  86 tcSimpl :: Bool                         -- True <=> simplify const insts
  87         -> TcTyVarSet s                 -- ``Global'' type variables
  88         -> TcTyVarSet s                 -- ``Local''  type variables
  89                                         -- ASSERT: both these tyvar sets are already zonked
  90         -> LIE s                        -- Given; these constrain only local tyvars
  91         -> LIE s                        -- Wanted
  92         -> TcM s (LIE s,                        -- Free
  93                   TcMonoBinds s,                -- Bindings
  94                   LIE s)                        -- Remaining wanteds; no dups
  95
  96 tcSimpl squash_consts global_tvs local_tvs givens wanteds
  97   =     -- ASSSERT: global_tvs and local_tvs are already zonked
  98         -- Make sure the insts fixed points of the substitution
  99     zonkLIE givens                      `thenNF_Tc` \ givens ->
 100     zonkLIE wanteds                     `thenNF_Tc` \ wanteds ->
 101
 102         -- Deal with duplicates and type constructors
 103     elimTyCons
 104          squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
 105          givens wanteds         `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
 106
 107         -- Now disambiguate if necessary
 108     let
 109         ambigs = filterBag is_ambiguous locals_and_ambigs
 110     in
 111     if not (isEmptyBag ambigs) then
 112         -- Some ambiguous dictionaries.  We now disambiguate them,
 113         -- which binds the offending type variables to suitable types in the
 114         -- substitution, and then we retry the whole process.  This
 115         -- time there won't be any ambiguous ones.
 116         -- There's no need to back-substitute on global and local tvs,
 117         -- because the ambiguous type variables can't be in either.
 118
 119         -- Why do we retry the whole process?  Because binding a type variable
 120         -- to a particular type might enable a short-cut simplification which
 121         -- elimTyCons will have missed the first time.
 122
 123         disambiguateDicts ambigs                `thenTc_`
 124         tcSimpl squash_consts global_tvs local_tvs givens wanteds
 125
 126     else
 127         -- No ambiguous dictionaries.  Just bash on with the results
 128         -- of the elimTyCons
 129
 130         -- Check for non-generalisable insts
 131     let
 132         locals          = locals_and_ambigs     -- ambigs is empty
 133         cant_generalise = filterBag (not . instCanBeGeneralised) locals
 134     in
 135     checkTc (isEmptyBag cant_generalise)
 136             (genCantGenErr cant_generalise)     `thenTc_`
 137
 138
 139         -- Deal with superclass relationships
 140     elimSCs givens locals               `thenNF_Tc` \ (sc_binds, locals2) ->
 141
 142          -- Finished
 143     returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2)
 144   where
 145     is_ambiguous (Dict _ _ ty _ _)
 146         = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
 147 \end{code}
 148
 149 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 150 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 151 top level defns we *do* squash constants, so that they stay local to a
 152 single defn.  This makes things which are inlined more likely to be
 153 exportable, because their constants are "inside".  Later passes will
 154 float them out if poss, after inlinings are sorted out.
 155
 156 \begin{code}
 157 tcSimplify
 158         :: TcTyVarSet s                 -- ``Local''  type variables
 159         -> LIE s                        -- Wanted
 160         -> TcM s (LIE s,                        -- Free
 161                   TcDictBinds s,                -- Bindings
 162                   LIE s)                        -- Remaining wanteds; no dups
 163
 164 tcSimplify local_tvs wanteds
 165   = tcGetGlobalTyVars                   `thenNF_Tc` \ global_tvs ->
 166     tcSimpl False global_tvs local_tvs emptyBag wanteds
 167 \end{code}
 168
 169 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 170 that there is an empty wanted-set at the end.  It may still return
 171 some of constant insts, which have to be resolved finally at the end.
 172
 173 \begin{code}
 174 tcSimplifyAndCheck
 175          :: TcTyVarSet s                -- ``Local''  type variables; ASSERT is fixpoint
 176          -> LIE s                       -- Given
 177          -> LIE s                       -- Wanted
 178          -> TcM s (LIE s,               -- Free
 179                    TcDictBinds s)       -- Bindings
 180
 181 tcSimplifyAndCheck local_tvs givens wanteds
 182   = tcGetGlobalTyVars                   `thenNF_Tc` \ global_tvs ->
 183     tcSimpl False global_tvs local_tvs
 184             givens wanteds              `thenTc` \ (free_insts, binds, wanteds') ->
 185     checkTc (isEmptyBag wanteds')
 186             (reduceErr wanteds')        `thenTc_`
 187     returnTc (free_insts, binds)
 188 \end{code}
 189
 190 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
 191 is not overloaded.
 192
 193 \begin{code}
 194 tcSimplifyRank2 :: TcTyVarSet s         -- ``Local'' type variables; ASSERT is fixpoint
 195                 -> LIE s                -- Given
 196                 -> TcM s (LIE s,                        -- Free
 197                           TcDictBinds s)        -- Bindings
 198
 199
 200 tcSimplifyRank2 local_tvs givens
 201   = zonkLIE givens                      `thenNF_Tc` \ givens' ->
 202     elimTyCons True
 203                (\tv -> not (tv `elementOfTyVarSet` local_tvs))
 204                 -- This predicate claims that all
 205                 -- any non-local tyvars are global,
 206                 -- thereby postponing dealing with
 207                 -- ambiguity until the enclosing Gen
 208                emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
 209
 210     checkTc (isEmptyBag wanteds) (reduceErr wanteds)    `thenTc_`
 211
 212     returnTc (free, dict_binds)
 213 \end{code}
 214
 215 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
 216 mechansim with the extra flag to say ``beat out constant insts''.
 217
 218 \begin{code}
 219 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
 220 tcSimplifyTop dicts
 221   = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts     `thenTc` \ (_, binds, _) ->
 222     returnTc binds
 223 \end{code}
 224
 225 %************************************************************************
 226 %*                                                                      *
 227 \subsection[elimTyCons]{@elimTyCons@}
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 \begin{code}
 232 elimTyCons :: Bool                              -- True <=> Simplify const insts
 233            -> (TcTyVar s -> Bool)               -- Free tyvar predicate
 234            -> LIE s                             -- Given
 235            -> LIE s                             -- Wanted
 236            -> TcM s (LIE s,                     -- Free
 237                      TcDictBinds s,             -- Bindings
 238                      LIE s                      -- Remaining wanteds; no dups;
 239                                                 -- dicts only (no Methods)
 240                )
 241 \end{code}
 242
 243 The bindings returned may mention any or all of ``givens'', so the
 244 order in which the generated binds are put together is {\em tricky}.
 245 Case~4 of @try@ is the general case to see.
 246
 247 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
 248
 249     (1) first look up @wanted@; this gives us one binding to heave in:
 250             wanted = rhs
 251
 252     (2) step (1) also gave us some @simpler_wanteds@; we simplify
 253         these and get some (simpler-wanted-)bindings {\em that must be
 254         in scope} for the @wanted=rhs@ binding above!
 255
 256     (3) we simplify the remaining @wanteds@ (recursive call), giving
 257         us yet more bindings.
 258
 259 The final arrangement of the {\em non-recursive} bindings is
 260
 261     let <simpler-wanted-binds> in
 262     let wanted = rhs           in
 263     let <yet-more-bindings> ...
 264
 265 \begin{code}
 266 elimTyCons squash_consts is_free_tv givens wanteds
 267   = eTC givens (bagToList wanteds)      `thenTc` \ (_, free, binds, irreds) ->
 268     returnTc (free,binds,irreds)
 269   where
 270 --    eTC :: LIE s -> [Inst s]
 271 --        -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s)
 272
 273     eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag)
 274
 275     eTC givens (wanted:wanteds)
 276     -- Case 0: same as an existing inst
 277       | maybeToBool maybe_equiv
 278       = eTC givens wanteds      `thenTc` \ (givens1, frees, binds, irreds) ->
 279         let
 280           -- Create a new binding iff it's needed
 281           this = expectJust "eTC" maybe_equiv
 282           new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this)))
 283                                                    `AndMonoBinds` binds
 284                     | otherwise                  = binds
 285         in
 286         returnTc (givens1, frees, new_binds, irreds)
 287
 288     -- Case 1: constrains no type variables at all
 289     -- In this case we have a quick go to see if it has an
 290     -- instance which requires no inputs (ie a constant); if so we use
 291     -- it; if not, we give up on the instance and just heave it out the
 292     -- top in the free result
 293       | isEmptyTyVarSet tvs_of_wanted
 294       = simplify_it squash_consts       {- If squash_consts is false,
 295                                            simplify only if trival -}
 296                     givens wanted wanteds
 297
 298     -- Case 2: constrains free vars only, so fling it out the top in free_ids
 299       | all is_free_tv (tyVarSetToList tvs_of_wanted)
 300       = eTC (wanted `consBag` givens) wanteds   `thenTc` \ (givens1, frees, binds, irreds) ->
 301         returnTc (givens1, wanted `consBag` frees, binds, irreds)
 302
 303     -- Case 3: is a dict constraining only a tyvar,
 304     -- so return it as part of the "wanteds" result
 305       | isTyVarDict wanted
 306       = eTC (wanted `consBag` givens) wanteds   `thenTc` \ (givens1, frees, binds, irreds) ->
 307         returnTc (givens1, frees, binds, wanted `consBag` irreds)
 308
 309     -- Case 4: is not a simple dict, so look up in instance environment
 310       | otherwise
 311       = simplify_it True {- Simplify even if not trivial -}
 312                     givens wanted wanteds
 313       where
 314         tvs_of_wanted  = tyVarsOfInst wanted
 315
 316         -- Look for something in "givens" that matches "wanted"
 317         Just the_equiv = maybe_equiv
 318         maybe_equiv    = foldBag seqMaybe try Nothing givens
 319         try given | wanted `matchesInst` given = Just given
 320                   | otherwise                  = Nothing
 321
 322
 323     simplify_it simplify_always givens wanted wanteds
 324         -- Recover immediately on no-such-instance errors
 325       = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE))
 326                   (simplify_one simplify_always givens wanted)
 327                                 `thenTc` \ (givens1, frees1, binds1, irreds1) ->
 328         eTC givens1 wanteds     `thenTc` \ (givens2, frees2, binds2, irreds2) ->
 329         returnTc (givens2, frees1 `plusLIE` frees2,
 330                            binds1 `AndMonoBinds` binds2,
 331                            irreds1 `plusLIE` irreds2)
 332
 333
 334     simplify_one simplify_always givens wanted
 335      | not (instBindingRequired wanted)
 336      =          -- No binding required for this chap, so squash right away
 337            lookupInst wanted            `thenTc` \ (simpler_wanteds, _) ->
 338            eTC givens simpler_wanteds   `thenTc` \ (givens1, frees1, binds1, irreds1) ->
 339            returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
 340
 341      | otherwise
 342      =          -- An binding is required for this inst
 343         lookupInst wanted               `thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) ->
 344
 345         if (not_var rhs && not simplify_always) then
 346            -- Ho ho!  It isn't trivial to simplify "wanted",
 347            -- because the rhs isn't a simple variable.  Unless the flag
 348            -- simplify_always is set, just give up now and
 349            -- just fling it out the top.
 350            returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE)
 351         else
 352            -- Aha! Either it's easy, or simplify_always is True
 353            -- so we must do it right here.
 354            eTC givens simpler_wanteds   `thenTc` \ (givens1, frees1, binds1, irreds1) ->
 355            returnTc (wanted `consLIE` givens1, frees1,
 356                      binds1 `AndMonoBinds` bind,
 357                      irreds1)
 358
 359     not_var :: TcExpr s -> Bool
 360     not_var (HsVar _) = False
 361     not_var other     = True
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection[elimSCs]{@elimSCs@}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 \begin{code}
 372 elimSCs :: LIE s                                -- Given; no dups
 373         -> LIE s                                -- Wanted; no dups; all dictionaries, all
 374                                                 -- constraining just a type variable
 375         -> NF_TcM s (TcDictBinds s,             -- Bindings
 376                      LIE s)                     -- Minimal wanted set
 377
 378 elimSCs givens wanteds
 379   = -- Sort the wanteds so that subclasses occur before superclasses
 380     elimSCs_help
 381         (filterBag isDict givens)       -- Filter out non-dictionaries
 382         (sortSC wanteds)
 383
 384 elimSCs_help :: LIE s                                   -- Given; no dups
 385              -> [Inst s]                                -- Wanted; no dups;
 386              -> NF_TcM s (TcDictBinds s,                -- Bindings
 387                           LIE s)                        -- Minimal wanted set
 388
 389 elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE)
 390
 391 elimSCs_help givens (wanted:wanteds)
 392   = trySC givens wanted                 `thenNF_Tc` \ (givens1, binds1, irreds1) ->
 393     elimSCs_help givens1 wanteds        `thenNF_Tc` \ (binds2, irreds2) ->
 394     returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2)
 395
 396
 397 trySC :: LIE s                          -- Givens
 398       -> Inst s                         -- Wanted
 399       -> NF_TcM s (LIE s,                       -- New givens,
 400                    TcDictBinds s,               -- Bindings
 401                    LIE s)                       -- Irreducible wanted set
 402
 403 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
 404   | not (maybeToBool maybe_best_subclass_chain)
 405   =     -- No superclass relationship
 406     returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted)
 407
 408   | otherwise
 409   =     -- There's a subclass relationship with a "given"
 410         -- Build intermediate dictionaries
 411     let
 412         theta = [ (clas, wanted_ty) | clas <- reverse classes ]
 413         -- The reverse is because the list comes back in the "wrong" order I think
 414     in
 415     newDictsAtLoc wanted_orig loc theta         `thenNF_Tc` \ (intermediates, _) ->
 416
 417         -- Create bindings for the wanted dictionary and the intermediates.
 418         -- Later binds may depend on earlier ones, so each new binding is pushed
 419         -- on the front of the accumulating parameter list of bindings
 420     let
 421         mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
 422           = ((dict_sub, dict_sub_class),
 423              (VarMonoBind (instToId dict)
 424                           (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class
 425                                                                               clas)))
 426                                             [ty])
 427                                      [instToId dict_sub])))
 428         (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
 429     in
 430     returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
 431                  andMonoBinds new_binds,
 432                  emptyLIE)
 433
 434   where
 435     maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
 436     Just (given, classes, _) = maybe_best_subclass_chain
 437
 438     choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2  = c1
 439                                                       | otherwise = c2
 440     choose_best Nothing            c2                             = c2
 441     choose_best c1                 Nothing                        = c1
 442
 443     find_subclass_chain given@(Dict _ given_class given_ty _ _)
 444          | wanted_ty `eqSimpleTy` given_ty
 445          = case (wanted_class `isSuperClassOf` given_class) of
 446
 447                  Just classes -> Just (given,
 448                                        classes,
 449                                        length classes)
 450
 451                  Nothing      -> Nothing
 452
 453          | otherwise = Nothing
 454
 455
 456 sortSC :: LIE s     -- Expected to be all dicts (no MethodIds), all of
 457                     -- which constrain type variables
 458        -> [Inst s]  -- Sorted with subclasses before superclasses
 459
 460 sortSC dicts = sortLt lt (bagToList dicts)
 461   where
 462     (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
 463        = maybeToBool (c2 `isSuperClassOf` c1)
 464         -- The ice is a bit thin here because this "lt" isn't a total order
 465         -- But it *is* transitive, so it works ok
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection[simple]{@Simple@ versions}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 Much simpler versions when there are no bindings to make!
 476
 477 @tcSimplifyThetas@ simplifies class-type constraints formed by
 478 @deriving@ declarations and when specialising instances.  We are
 479 only interested in the simplified bunch of class/type constraints.
 480
 481 \begin{code}
 482 tcSimplifyThetas :: (Class -> ClassInstEnv)             -- How to find the ClassInstEnv
 483                  -> [(Class, TauType)]                  -- Given
 484                  -> [(Class, TauType)]                  -- Wanted
 485                  -> TcM s [(Class, TauType)]
 486
 487
 488 tcSimplifyThetas inst_mapper given wanted
 489   = elimTyConsSimple inst_mapper wanted `thenTc`    \ wanted1 ->
 490     returnTc (elimSCsSimple given wanted1)
 491 \end{code}
 492
 493 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 494 used with \tr{default} declarations.  We are only interested in
 495 whether it worked or not.
 496
 497 \begin{code}
 498 tcSimplifyCheckThetas :: [(Class, TauType)]     -- Simplify this to nothing at all
 499                       -> TcM s ()
 500
 501 tcSimplifyCheckThetas theta
 502   = elimTyConsSimple classInstEnv theta    `thenTc`     \ theta1 ->
 503     ASSERT( null theta1 )
 504     returnTc ()
 505 \end{code}
 506
 507
 508 \begin{code}
 509 elimTyConsSimple :: (Class -> ClassInstEnv)
 510                  -> [(Class,Type)]
 511                  -> TcM s [(Class,Type)]
 512 elimTyConsSimple inst_mapper theta
 513   = elim theta
 514   where
 515     elim []               = returnTc []
 516     elim ((clas,ty):rest) = elim_one clas ty    `thenTc` \ r1 ->
 517                             elim rest           `thenTc` \ r2 ->
 518                             returnTc (r1++r2)
 519
 520     elim_one clas ty
 521         = case getTyVar_maybe ty of
 522
 523             Just tv   -> returnTc [(clas,ty)]
 524
 525             otherwise -> recoverTc (returnTc []) $
 526                          lookupSimpleInst (inst_mapper clas) clas ty    `thenTc` \ theta ->
 527                          elim theta
 528
 529 elimSCsSimple :: [(Class,Type)]         -- Given
 530               -> [(Class,Type)]         -- Wanted
 531               -> [(Class,Type)]         -- Subset of wanted; no dups, no subclass relnships
 532
 533 elimSCsSimple givens [] = []
 534 elimSCsSimple givens (c_t@(clas,ty) : rest)
 535   | any (`subsumes` c_t) givens ||
 536     any (`subsumes` c_t) rest                           -- (clas,ty) is old hat
 537   = elimSCsSimple givens rest
 538   | otherwise                                           -- (clas,ty) is new
 539   = c_t : elimSCsSimple (c_t : givens) rest
 540   where
 541     rest' = elimSCsSimple rest
 542     (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 &&
 543                                  (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
 544 -- We deal with duplicates here   ^^^^^^^^
 545 -- It's a simple place to do it, although it's done in elimTyCons in the
 546 -- full-blown version of the simpifier.
 547 \end{code}
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 When doing a binding group, we may have @Insts@ of local functions.
 556 For example, we might have...
 557 \begin{verbatim}
 558 let f x = x + 1     -- orig local function (overloaded)
 559     f.1 = f Int     -- two instances of f
 560     f.2 = f Float
 561  in
 562     (f.1 5, f.2 6.7)
 563 \end{verbatim}
 564 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 565 where @f@ is in scope; those @Insts@ must certainly not be passed
 566 upwards towards the top-level.  If the @Insts@ were binding-ified up
 567 there, they would have unresolvable references to @f@.
 568
 569 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 570 For each method @Inst@ in the @init_lie@ that mentions one of the
 571 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 572 @LIE@), as well as the @HsBinds@ generated.
 573
 574 \begin{code}
 575 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
 576
 577 bindInstsOfLocalFuns init_lie local_ids
 578   = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
 579   where
 580     bind_inst inst@(Method uniq (TcId id) tys _ _ orig loc) (insts, binds)
 581       | id `is_elem` local_ids
 582       = lookupInst inst         `thenTc` \ (dict_insts, bind) ->
 583         returnTc (listToBag dict_insts `plusLIE` insts,
 584                   bind `AndMonoBinds` binds)
 585
 586     bind_inst some_other_inst (insts, binds)
 587         -- Either not a method, or a method instance for an id not in local_ids
 588       = returnTc (some_other_inst `consBag` insts, binds)
 589
 590     is_elem = isIn "bindInstsOfLocalFuns"
 591 \end{code}
 592
 593
 594 %************************************************************************
 595 %*                                                                      *
 596 \section[Disambig]{Disambiguation of overloading}
 597 %*                                                                      *
 598 %************************************************************************
 599
 600
 601 If a dictionary constrains a type variable which is
 602 \begin{itemize}
 603 \item
 604 not mentioned in the environment
 605 \item
 606 and not mentioned in the type of the expression
 607 \end{itemize}
 608 then it is ambiguous. No further information will arise to instantiate
 609 the type variable; nor will it be generalised and turned into an extra
 610 parameter to a function.
 611
 612 It is an error for this to occur, except that Haskell provided for
 613 certain rules to be applied in the special case of numeric types.
 614
 615 Specifically, if
 616 \begin{itemize}
 617 \item
 618 at least one of its classes is a numeric class, and
 619 \item
 620 all of its classes are numeric or standard
 621 \end{itemize}
 622 then the type variable can be defaulted to the first type in the
 623 default-type list which is an instance of all the offending classes.
 624
 625 So here is the function which does the work.  It takes the ambiguous
 626 dictionaries and either resolves them (producing bindings) or
 627 complains.  It works by splitting the dictionary list by type
 628 variable, and using @disambigOne@ to do the real business.
 629
 630 IMPORTANT: @disambiguate@ assumes that its argument dictionaries
 631 constrain only a simple type variable.
 632
 633 \begin{code}
 634 type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
 635
 636 disambiguateDicts :: LIE s -> TcM s ()
 637
 638 disambiguateDicts insts
 639   = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
 640     returnTc ()
 641   where
 642     inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
 643     (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
 644
 645     mk_inst_info dict@(Dict _ clas ty _ _)
 646       = (dict, clas, getTyVar "disambiguateDicts" ty)
 647 \end{code}
 648
 649 @disambigOne@ assumes that its arguments dictionaries constrain all
 650 the same type variable.
 651
 652 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
 653 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
 654 the most common use of defaulting is code like:
 655 \begin{verbatim}
 656         _ccall_ foo     `seqPrimIO` bar
 657 \end{verbatim}
 658 Since we're not using the result of @foo@, the result if (presumably)
 659 @void@.
 660
 661 \begin{code}
 662 disambigOne :: [SimpleDictInfo s] -> TcM s ()
 663
 664 disambigOne dict_infos
 665   |  any isNumericClass classes && all isStandardClass classes
 666   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 667         -- SO, TRY DEFAULT TYPES IN ORDER
 668
 669         -- Failure here is caused by there being no type in the
 670         -- default list which can satisfy all the ambiguous classes.
 671         -- For example, if Real a is reqd, but the only type in the
 672         -- default list is Int.
 673     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
 674     let
 675       try_default []    -- No defaults work, so fail
 676         = failTc (ambigErr dicts)
 677
 678       try_default (default_ty : default_tys)
 679         = tryTc (try_default default_tys) $     -- If default_ty fails, we try
 680                                                 -- default_tys instead
 681           tcSimplifyCheckThetas thetas  `thenTc` \ _ ->
 682           returnTc default_ty
 683         where
 684           thetas = classes `zip` repeat default_ty
 685     in
 686         -- See if any default works, and if so bind the type variable to it
 687     try_default default_tys             `thenTc` \ chosen_default_ty ->
 688     tcInstType [] chosen_default_ty     `thenNF_Tc` \ chosen_default_tc_ty ->   -- Tiresome!
 689     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
 690
 691   | all isCcallishClass classes
 692   =     -- Default CCall stuff to (); we don't even both to check that () is an
 693         -- instance of CCallable/CReturnable, because we know it is.
 694     unifyTauTy (mkTyVarTy tyvar) unitTy
 695
 696   | otherwise -- No defaults
 697   = failTc (ambigErr dicts)
 698
 699   where
 700     (_,_,tyvar) = head dict_infos               -- Should be non-empty
 701     dicts   = [dict | (dict,_,_) <- dict_infos]
 702     classes = [clas | (_,clas,_) <- dict_infos]
 703
 704 \end{code}
 705
 706
 707
 708 Errors and contexts
 709 ~~~~~~~~~~~~~~~~~~~
 710 ToDo: for these error messages, should we note the location as coming
 711 from the insts, or just whatever seems to be around in the monad just
 712 now?
 713
 714 \begin{code}
 715 genCantGenErr insts sty -- Can't generalise these Insts
 716   = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"))
 717            4  (vcat (map (ppr sty) (bagToList insts)))
 718 \end{code}
 719
 720 \begin{code}
 721 ambigErr dicts sty
 722   = sep [text "Ambiguous context" <+> pprLIE sty lie,
 723          nest 4 (pprLIEInFull sty lie)
 724     ]
 725   where
 726     lie = listToBag dicts       -- Yuk
 727 \end{code}
 728
 729 @reduceErr@ complains if we can't express required dictionaries in
 730 terms of the signature.
 731
 732 \begin{code}
 733 reduceErr lie sty
 734   = sep [text "Context" <+> pprLIE sty lie,
 735          nest 4 (text "required by inferred type, but missing on a type signature"),
 736          nest 4 (pprLIEInFull sty lie)
 737     ]
 738 \end{code}
 739
 740