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