ghc/compiler/typecheck/TcSimplify.lhs

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