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