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