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