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, Qualifier, HsType, ArithSeqInfo, Fixity,
  19                           GRHSsAndBinds, Stmt, 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 (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        = if ty1 `eqSimpleTy` ty2 then
 461                 maybeToBool (c2 `isSuperClassOf` c1)
 462          else
 463                 -- Order is immaterial, I think...
 464                 False
 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, (id,rhs)) ->
 582         returnTc (listToBag dict_insts `plusLIE` insts,
 583                   VarMonoBind id rhs `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   = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):")
 716            4  (ppAboves (map (ppr sty) (bagToList insts)))
 717 \end{code}
 718
 719 \begin{code}
 720 ambigErr insts sty
 721   = ppAboves (map (pprInst sty "Ambiguous overloading") insts)
 722 \end{code}
 723
 724 @reduceErr@ complains if we can't express required dictionaries in
 725 terms of the signature.
 726
 727 \begin{code}
 728 reduceErr insts sty
 729   = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature")
 730                   (bagToList insts))
 731 \end{code}
 732
 733