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