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