ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcSimplify]{TcSimplify}
   5
   6 Notes:
   7
   8 Inference (local definitions)
   9 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  10 If the inst constrains a local type variable, then
  11   [ReduceMe] if it's a literal or method inst, reduce it
  12
  13   [DontReduce] otherwise see whether the inst is just a constant
  14     if succeed, use it
  15     if not, add original to context
  16   This check gets rid of constant dictionaries without
  17   losing sharing.
  18
  19 If the inst does not constrain a local type variable then
  20   [Free] then throw it out as free.
  21
  22 Inference (top level definitions)
  23 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  24 If the inst does not constrain a local type variable, then
  25   [FreeIfTautological] try for tautology;
  26       if so, throw it out as free
  27          (discarding result of tautology check)
  28       if not, make original inst part of the context
  29          (eliminating superclasses as usual)
  30
  31 If the inst constrains a local type variable, then
  32    as for inference (local defns)
  33
  34
  35 Checking (local defns)
  36 ~~~~~~~~
  37 If the inst constrains a local type variable then
  38   [ReduceMe] reduce (signal error on failure)
  39
  40 If the inst does not constrain a local type variable then
  41   [Free] throw it out as free.
  42
  43 Checking (top level)
  44 ~~~~~~~~~~~~~~~~~~~~
  45 If the inst constrains a local type variable then
  46    as for checking (local defns)
  47
  48 If the inst does not constrain a local type variable then
  49    as for checking (local defns)
  50
  51
  52
  53 Checking once per module
  54 ~~~~~~~~~~~~~~~~~~~~~~~~~
  55 For dicts of the form (C a), where C is a std class
  56   and "a" is a type variable,
  57   [DontReduce] add to context
  58
  59 otherwise [ReduceMe] always reduce
  60
  61 [NB: we may generate one Tree [Int] dict per module, so
  62      sharing is not complete.]
  63
  64 Sort out ambiguity at the end.
  65
  66 Principal types
  67 ~~~~~~~~~~~~~~~
  68 class C a where
  69   op :: a -> a
  70
  71 f x = let g y = op (y::Int) in True
  72
  73 Here the principal type of f is (forall a. a->a)
  74 but we'll produce the non-principal type
  75     f :: forall a. C Int => a -> a
  76
  77
  78 Ambiguity
  79 ~~~~~~~~~
  80 Consider this:
  81
  82         instance C (T a) Int  where ...
  83         instance C (T a) Bool where ...
  84
  85 and suppose we infer a context
  86
  87             C (T x) y
  88
  89 from some expression, where x and y are type varibles,
  90 and x is ambiguous, and y is being quantified over.
  91 Should we complain, or should we generate the type
  92
  93        forall x y. C (T x) y => <type not involving x>
  94
  95 The idea is that at the call of the function we might
  96 know that y is Int (say), so the "x" isn't really ambiguous.
  97 Notice that we have to add "x" to the type variables over
  98 which we generalise.
  99
 100 Something similar can happen even if C constrains only ambiguous
 101 variables.  Suppose we infer the context
 102
 103        C [x]
 104
 105 where x is ambiguous.  Then we could infer the type
 106
 107        forall x. C [x] => <type not involving x>
 108
 109 in the hope that at the call site there was an instance
 110 decl such as
 111
 112        instance Num a => C [a] where ...
 113
 114 and hence the default mechanism would resolve the "a".
 115
 116
 117 \begin{code}
 118 module TcSimplify (
 119         tcSimplify, tcSimplifyAndCheck,
 120         tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
 121         bindInstsOfLocalFuns
 122     ) where
 123
 124 #include "HsVersions.h"
 125
 126 import HsSyn            ( MonoBinds(..), HsExpr(..), andMonoBinds )
 127 import TcHsSyn          ( TcExpr, TcIdOcc(..), TcIdBndr,
 128                           TcMonoBinds, TcDictBinds
 129                         )
 130
 131 import TcMonad
 132 import Inst             ( lookupInst, lookupSimpleInst, LookupInstResult(..),
 133                           tyVarsOfInst,
 134                           isTyVarDict, isDict, isStdClassTyVarDict, isMethodFor,
 135                           instToId, instBindingRequired, instCanBeGeneralised,
 136                           newDictFromOld,
 137                           instLoc, getDictClassTys,
 138                           pprInst, zonkInst,
 139                           Inst(..), LIE, pprInsts, pprInstsInFull, mkLIE,
 140                           InstOrigin(..), pprOrigin
 141                         )
 142 import TcEnv            ( TcIdOcc(..), tcGetGlobalTyVars )
 143 import TcType           ( TcType, TcTyVar, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
 144 import Unify            ( unifyTauTy )
 145 import Id               ( mkIdSet )
 146
 147 import Bag              ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
 148                           snocBag, consBag, unionBags, isEmptyBag )
 149 import Class            ( Class, ClassInstEnv, classBigSig, classInstEnv )
 150 import PrelInfo         ( isNumericClass, isCcallishClass )
 151
 152 import Maybes           ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
 153 import Type             ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
 154                           isTyVarTy, getTyVar_maybe, instantiateThetaTy
 155                         )
 156 import PprType          ( pprConstraint )
 157 import TysWiredIn       ( intTy, unitTy )
 158 import TyVar            ( elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
 159                           intersectTyVarSets, unionManyTyVarSets,
 160                           isEmptyTyVarSet, tyVarSetToList,
 161                           zipTyVarEnv, emptyTyVarEnv
 162                         )
 163 import FiniteMap
 164 import BasicTypes       ( TopLevelFlag(..) )
 165 import Unique           ( Unique )
 166 import Outputable
 167 import Util
 168 import List             ( partition )
 169 \end{code}
 170
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection[tcSimplify-main]{Main entry function}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 179 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 180 top level defns we *do* squash constants, so that they stay local to a
 181 single defn.  This makes things which are inlined more likely to be
 182 exportable, because their constants are "inside".  Later passes will
 183 float them out if poss, after inlinings are sorted out.
 184
 185 \begin{code}
 186 tcSimplify
 187         :: SDoc
 188         -> TopLevelFlag
 189         -> TcTyVarSet s                 -- ``Local''  type variables
 190         -> LIE s                        -- Wanted
 191         -> TcM s (LIE s,                        -- Free
 192                   TcDictBinds s,                -- Bindings
 193                   LIE s)                        -- Remaining wanteds; no dups
 194
 195 tcSimplify str top_lvl local_tvs wanteds
 196   = tcSimpl str top_lvl local_tvs Nothing wanteds
 197 \end{code}
 198
 199 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 200 that there is an empty wanted-set at the end.  It may still return
 201 some of constant insts, which have to be resolved finally at the end.
 202
 203 \begin{code}
 204 tcSimplifyAndCheck
 205          :: SDoc
 206          -> TcTyVarSet s                -- ``Local''  type variables; ASSERT is fixpoint
 207          -> LIE s                       -- Given
 208          -> LIE s                       -- Wanted
 209          -> TcM s (LIE s,               -- Free
 210                    TcDictBinds s)       -- Bindings
 211
 212 tcSimplifyAndCheck str local_tvs givens wanteds
 213   = tcSimpl str top_lvl local_tvs (Just givens) wanteds `thenTc` \ (free_insts, binds, new_wanteds) ->
 214     ASSERT( isEmptyBag new_wanteds )
 215     returnTc (free_insts, binds)
 216   where
 217     top_lvl = error "tcSimplifyAndCheck"        -- Never needed
 218 \end{code}
 219
 220 \begin{code}
 221 tcSimpl :: SDoc
 222         -> TopLevelFlag
 223         -> TcTyVarSet s                 -- ``Local''  type variables
 224                                         -- ASSERT: this tyvar set is already zonked
 225         -> Maybe (LIE s)                -- Given; these constrain only local tyvars
 226                                         --        Nothing => just simplify
 227                                         --        Just g  => check that g entails wanteds
 228         -> LIE s                        -- Wanted
 229         -> TcM s (LIE s,                        -- Free
 230                   TcMonoBinds s,                -- Bindings
 231                   LIE s)                        -- Remaining wanteds; no dups
 232
 233 tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie
 234   =     -- ASSSERT: local_tvs are already zonked
 235     reduceContext str try_me
 236                   givens
 237                   (bagToList wanted_lie)        `thenTc` \ (binds, frees, irreds) ->
 238
 239         -- Check for non-generalisable insts
 240     let
 241         cant_generalise = filter (not . instCanBeGeneralised) irreds
 242     in
 243     checkTc (null cant_generalise)
 244             (genCantGenErr cant_generalise)     `thenTc_`
 245
 246          -- Finished
 247     returnTc (mkLIE frees, binds, mkLIE irreds)
 248   where
 249     givens = case maybe_given_lie of
 250                   Just given_lie -> bagToList given_lie
 251                   Nothing        -> []
 252
 253     checking_against_signature = maybeToBool maybe_given_lie
 254     is_top_level = case top_lvl of { TopLevel -> True; other -> False }
 255
 256     try_me inst
 257       -- Does not constrain a local tyvar
 258       | isEmptyTyVarSet (inst_tyvars `intersectTyVarSets` local_tvs)
 259       = -- if not checking_against_signature && is_top_level then
 260         --   FreeIfTautological           -- Special case for inference on
 261         --                                -- top-level defns
 262         -- else
 263
 264         Free
 265
 266       -- When checking against a given signature we always reduce
 267       -- until we find a match against something given, or can't reduce
 268       |  checking_against_signature
 269       = ReduceMe CarryOn
 270
 271       -- So we're infering (not checking) the type, and
 272       -- the inst constrains a local type variable
 273       | otherwise
 274       = if isDict inst then
 275            DontReduce       -- Dicts
 276         else
 277            ReduceMe CarryOn    -- Lits and Methods
 278
 279       where
 280         inst_tyvars     = tyVarsOfInst inst
 281 \end{code}
 282
 283
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection{Data types for the reduction mechanism}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 The main control over context reduction is here
 292
 293 \begin{code}
 294 data WhatToDo
 295  = ReduceMe               -- Reduce this
 296         NoInstanceAction  -- What to do if there's no such instance
 297
 298  | DontReduce             -- Return as irreducible
 299
 300  | Free                   -- Return as free
 301
 302  | FreeIfTautological     -- Return as free iff it's tautological;
 303                           -- if not, return as irreducible
 304
 305 data NoInstanceAction
 306   = CarryOn             -- Produce an error message, but keep on with next inst
 307
 308   | Stop                -- Produce an error message and stop reduction
 309
 310   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 311                         -- produce an error message of any kind.
 312                         -- It might be quite legitimate
 313                         -- such as (Eq a)!
 314 \end{code}
 315
 316
 317
 318 \begin{code}
 319 type RedState s
 320   = (Avails s,          -- What's available
 321      [Inst s],          -- Insts for which try_me returned Free
 322      [Inst s]           -- Insts for which try_me returned DontReduce
 323     )
 324
 325 type Avails s = FiniteMap (Inst s) (Avail s)
 326
 327 data Avail s
 328   = Avail
 329         (TcIdOcc s)     -- The "main Id"; that is, the Id for the Inst that
 330                         -- caused this avail to be put into the finite map in the first place
 331                         -- It is this Id that is bound to the RHS.
 332
 333         (RHS s)         -- The RHS: an expression whose value is that Inst.
 334                         -- The main Id should be bound to this RHS
 335
 336         [TcIdOcc s]     -- Extra Ids that must all be bound to the main Id.
 337                         -- At the end we generate a list of bindings
 338                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 339
 340 data RHS s
 341   = NoRhs               -- Used for irreducible dictionaries,
 342                         -- which are going to be lambda bound, or for those that are
 343                         -- suppplied as "given" when checking againgst a signature.
 344                         --
 345                         -- NoRhs is also used for Insts like (CCallable f)
 346                         -- where no witness is required.
 347
 348   | Rhs                 -- Used when there is a RHS
 349         (TcExpr s)
 350         Bool            -- True => the RHS simply selects a superclass dictionary
 351                         --         from a subclass dictionary.
 352                         -- False => not so.
 353                         -- This is useful info, because superclass selection
 354                         -- is cheaper than building the dictionary using its dfun,
 355                         -- and we can sometimes replace the latter with the former
 356
 357   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 358                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 359                         -- the finite map, with an PassiveScSel.  Then if the
 360                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 361         (TcExpr s)
 362         [Inst s]        -- List of Insts that are free in the RHS.
 363                         -- If the main Id is subsequently needed, we toss this list into
 364                         -- the needed-inst pool so that we make sure their bindings
 365                         -- will actually be produced.
 366                         --
 367                         -- Invariant: these Insts are already in the finite mapping
 368
 369
 370 pprAvails avails = vcat (map pp (eltsFM avails))
 371   where
 372     pp (Avail main_id rhs ids)
 373       = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 374
 375 pprRhs NoRhs = text "<no rhs>"
 376 pprRhs (Rhs rhs b) = ppr rhs
 377 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 378 \end{code}
 379
 380
 381 %************************************************************************
 382 %*                                                                      *
 383 \subsection[reduce]{@reduce@}
 384 %*                                                                      *
 385 %************************************************************************
 386
 387 The main entry point for context reduction is @reduceContext@:
 388
 389 \begin{code}
 390 reduceContext :: SDoc -> (Inst s -> WhatToDo)
 391               -> [Inst s]       -- Given
 392               -> [Inst s]       -- Wanted
 393               -> TcM s (TcDictBinds s, [Inst s], [Inst s])
 394
 395 reduceContext str try_me givens wanteds
 396   =     -- Zonking first
 397     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 398     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 399
 400 {-
 401     pprTrace "reduceContext" (vcat [
 402              text "----------------------",
 403              str,
 404              text "given" <+> ppr givens,
 405              text "wanted" <+> ppr wanteds,
 406              text "----------------------"
 407              ]) $
 408 -}
 409
 410         -- Build the Avail mapping from "givens"
 411     foldlNF_Tc addGiven emptyFM givens          `thenNF_Tc` \ avails ->
 412
 413         -- Do the real work
 414     reduce try_me wanteds (avails, [], [])      `thenTc` \ (avails, frees, irreds) ->
 415
 416         -- Extract the bindings from avails
 417     let
 418        binds = foldFM add_bind EmptyMonoBinds avails
 419
 420        add_bind _ (Avail main_id rhs ids) binds
 421          = foldr add_synonym (add_rhs_bind rhs binds) ids
 422          where
 423            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 424            add_rhs_bind other       binds = binds
 425
 426            -- Add the trivial {x = y} bindings
 427            -- The main Id can end up in the list when it's first added passively
 428            -- and then activated, so we have to filter it out.  A bit of a hack.
 429            add_synonym id binds
 430              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 431              | otherwise     = binds
 432     in
 433 {-
 434     pprTrace ("reduceContext1") (vcat [
 435              text "----------------------",
 436              str,
 437              text "given" <+> ppr givens,
 438              text "wanted" <+> ppr wanteds,
 439              text "----",
 440              pprAvails avails,
 441              text "----------------------"
 442              ]) $
 443 -}
 444     returnTc (binds, frees, irreds)
 445 \end{code}
 446
 447 The main context-reduction function is @reduce@.  Here's its game plan.
 448
 449 \begin{code}
 450 reduce :: (Inst s -> WhatToDo)
 451        -> [Inst s]
 452        -> RedState s
 453        -> TcM s (RedState s)
 454 \end{code}
 455
 456 @reduce@ is passed
 457      try_me:    given an inst, this function returns
 458                   Reduce       reduce this
 459                   DontReduce   return this in "irreds"
 460                   Free         return this in "frees"
 461
 462      wanteds:   The list of insts to reduce
 463      state:     An accumulating parameter of type RedState
 464                 that contains the state of the algorithm
 465
 466   It returns a RedState.
 467
 468
 469 \begin{code}
 470     -- Base case: we're done!
 471 reduce try_me [] state = returnTc state
 472
 473 reduce try_me (wanted:wanteds) state@(avails, frees, irreds)
 474
 475     -- It's the same as an existing inst, or a superclass thereof
 476   | wanted `elemFM` avails
 477   = reduce try_me wanteds (activate avails wanted, frees, irreds)
 478
 479     -- It should be reduced
 480   | case try_me_result of { ReduceMe _ -> True; _ -> False }
 481   = lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 482
 483     case lookup_result of
 484       GenInst wanteds' rhs -> use_instance wanteds' rhs
 485       SimpleInst rhs       -> use_instance []       rhs
 486
 487       NoInstance ->    -- No such instance!
 488                        -- Decide what to do based on the no_instance_action requested
 489                  case no_instance_action of
 490                    Stop ->              -- Fail
 491                             addNoInstanceErr wanted             `thenNF_Tc_`
 492                             failTc
 493
 494                    CarryOn ->           -- Carry on.
 495                                 -- Add the bad guy to the avails to suppress similar
 496                                 -- messages from other insts in wanteds
 497                             addNoInstanceErr wanted     `thenNF_Tc_`
 498                             addGiven avails wanted      `thenNF_Tc` \ avails' ->
 499                             reduce try_me wanteds (avails', frees, irreds)      -- Carry on
 500
 501                    AddToIrreds ->       -- Add the offending insts to the irreds
 502                                   add_to_irreds
 503
 504
 505
 506     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 507   | case try_me_result of { Free -> True; _ -> False }
 508   =     -- First, see if the inst can be reduced to a constant in one step
 509     lookupInst wanted     `thenNF_Tc` \ lookup_result ->
 510     case lookup_result of
 511        SimpleInst rhs -> use_instance [] rhs
 512        other          -> add_to_frees
 513
 514     -- It's free and this is a top level binding, so
 515     -- check whether it's a tautology or not
 516   | case try_me_result of { FreeIfTautological -> True; _ -> False }
 517   =     -- Try for tautology
 518     tryTc
 519           -- If tautology trial fails, add to irreds
 520           (addGiven avails wanted      `thenNF_Tc` \ avails' ->
 521            returnTc (avails', frees, wanted:irreds))
 522
 523           -- If tautology succeeds, just add to frees
 524           (reduce try_me_taut [wanted] (avails, [], [])         `thenTc_`
 525            returnTc (avails, wanted:frees, irreds))
 526                                                                 `thenTc` \ state' ->
 527     reduce try_me wanteds state'
 528
 529
 530     -- It's irreducible (or at least should not be reduced)
 531   | otherwise
 532   = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
 533         -- See if the inst can be reduced to a constant in one step
 534     lookupInst wanted     `thenNF_Tc` \ lookup_result ->
 535     case lookup_result of
 536        SimpleInst rhs -> use_instance [] rhs
 537        other          -> add_to_irreds
 538
 539   where
 540         -- The three main actions
 541     add_to_frees  = reduce try_me wanteds (avails, wanted:frees, irreds)
 542
 543     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 544                     reduce try_me wanteds (avails',  frees, wanted:irreds)
 545
 546     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 547                                 reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds)
 548
 549
 550     try_me_result               = try_me wanted
 551     ReduceMe no_instance_action = try_me_result
 552
 553     -- The try-me to use when trying to identify tautologies
 554     -- It blunders on reducing as much as possible
 555     try_me_taut inst = ReduceMe Stop    -- No error recovery
 556 \end{code}
 557
 558
 559 \begin{code}
 560 activate :: Avails s -> Inst s -> Avails s
 561          -- Activate the binding for Inst, ensuring that a binding for the
 562          -- wanted Inst will be generated.
 563          -- (Activate its parent if necessary, recursively).
 564          -- Precondition: the Inst is in Avails already
 565
 566 activate avails wanted
 567   | not (instBindingRequired wanted)
 568   = avails
 569
 570   | otherwise
 571   = case lookupFM avails wanted of
 572
 573       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 574                foldl activate avails' insts      -- Activate anything it needs
 575              where
 576                avails' = addToFM avails wanted avail'
 577                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 578
 579       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 580                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 581
 582       Nothing -> panic "activate"
 583   where
 584       wanted_id = instToId wanted
 585
 586 addWanted avails wanted rhs_expr
 587   = ASSERT( not (wanted `elemFM` avails) )
 588     returnNF_Tc (addToFM avails wanted avail)
 589         -- NB: we don't add the thing's superclasses too!
 590         -- Why not?  Because addWanted is used when we've successfully used an
 591         -- instance decl to reduce something; e.g.
 592         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 593         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 594         -- If we put the superclasses of "d" in avails, then we might end up
 595         -- expressing "d1" in terms of "d", which would be a disaster.
 596   where
 597     avail = Avail (instToId wanted) rhs []
 598
 599     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 600         | otherwise                  = NoRhs
 601
 602 addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
 603 addGiven avails given
 604   =      -- ASSERT( not (given `elemFM` avails) )
 605          -- This assertion isn' necessarily true.  It's permitted
 606          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 607          -- and when typechecking instance decls we generate redundant "givens" too.
 608     addAvail avails given avail
 609   where
 610     avail = Avail (instToId given) NoRhs []
 611
 612 addAvail avails wanted avail
 613   = addSuperClasses (addToFM avails wanted avail) wanted
 614
 615 addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
 616                 -- Add all the superclasses of the Inst to Avails
 617                 -- Invariant: the Inst is already in Avails.
 618
 619 addSuperClasses avails dict
 620   | not (isDict dict)
 621   = returnNF_Tc avails
 622
 623   | otherwise   -- It is a dictionary
 624   = tcInstTheta env sc_theta            `thenNF_Tc` \ sc_theta' ->
 625     foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
 626   where
 627     (clas, tys) = getDictClassTys dict
 628
 629     (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
 630     env       = zipTyVarEnv tyvars tys
 631
 632     add_sc avails ((super_clas, super_tys), sc_sel)
 633       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 634         let
 635            sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
 636                                        tys)
 637                                 [instToId dict]
 638         in
 639         case lookupFM avails super_dict of
 640
 641              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 642                   -- Already there, but not as a superclass selector
 643                   -- No need to look at its superclasses; since it's there
 644                   --    already they must be already in avails
 645                   -- However, we must remember to activate the dictionary
 646                   -- from which it is (now) generated
 647                   returnNF_Tc (activate avails' dict)
 648                 where
 649                   avails' = addToFM avails super_dict avail
 650                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 651
 652              Just (Avail _ _ _) -> returnNF_Tc avails
 653                   -- Already there; no need to do anything
 654
 655              Nothing ->
 656                   -- Not there at all, so add it, and its superclasses
 657                   addAvail avails super_dict avail
 658                 where
 659                   avail   = Avail (instToId super_dict)
 660                                   (PassiveScSel sc_sel_rhs [dict])
 661                                   []
 662 \end{code}
 663
 664 %************************************************************************
 665 %*                                                                      *
 666 \subsection[simple]{@Simple@ versions}
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 Much simpler versions when there are no bindings to make!
 671
 672 @tcSimplifyThetas@ simplifies class-type constraints formed by
 673 @deriving@ declarations and when specialising instances.  We are
 674 only interested in the simplified bunch of class/type constraints.
 675
 676 It simplifies to constraints of the form (C a b c) where
 677 a,b,c are type variables.  This is required for the context of
 678 instance declarations.
 679
 680 \begin{code}
 681 tcSimplifyThetas :: (Class -> ClassInstEnv)             -- How to find the ClassInstEnv
 682                  -> ThetaType                           -- Wanted
 683                  -> TcM s ThetaType                     -- Needed; of the form C a b c
 684                                                         -- where a,b,c are type variables
 685
 686 tcSimplifyThetas inst_mapper wanteds
 687   = reduceSimple inst_mapper [] wanteds         `thenNF_Tc` \ irreds ->
 688     let
 689         -- Check that the returned dictionaries are of the form (C a b c)
 690         bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)]
 691     in
 692     if null bad_guys then
 693         returnTc irreds
 694     else
 695        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 696        failTc
 697 \end{code}
 698
 699 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 700 used with \tr{default} declarations.  We are only interested in
 701 whether it worked or not.
 702
 703 \begin{code}
 704 tcSimplifyCheckThetas :: ThetaType      -- Given
 705                       -> ThetaType      -- Wanted
 706                       -> TcM s ()
 707
 708 tcSimplifyCheckThetas givens wanteds
 709   = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`     \ irreds ->
 710     if null irreds then
 711        returnTc ()
 712     else
 713        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 714        failTc
 715
 716 addNoInstErr (c,ts) = addErrTc (noDictInstanceErr c ts)
 717 \end{code}
 718
 719
 720 \begin{code}
 721 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
 722                     -- True  => irreducible
 723                     -- False => given, or can be derived from a given or from an irreducible
 724
 725 reduceSimple :: (Class -> ClassInstEnv)
 726              -> ThetaType               -- Given
 727              -> ThetaType               -- Wanted
 728              -> NF_TcM s ThetaType      -- Irreducible
 729
 730 reduceSimple inst_mapper givens wanteds
 731   = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
 732     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 733   where
 734     givens_fm     = foldl addNonIrred emptyFM givens
 735
 736 reduce_simple :: (Class -> ClassInstEnv)
 737               -> AvailsSimple
 738               -> ThetaType
 739               -> NF_TcM s AvailsSimple
 740
 741 reduce_simple inst_mapper givens []
 742   =          -- Finished, so pull out the needed ones
 743     returnNF_Tc givens
 744
 745 reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds)
 746   | wanted `elemFM` givens
 747   = reduce_simple inst_mapper givens wanteds
 748
 749   | otherwise
 750   = lookupSimpleInst (inst_mapper clas) clas tys        `thenNF_Tc` \ maybe_theta ->
 751
 752     case maybe_theta of
 753       Nothing ->    reduce_simple inst_mapper (addIrred    givens wanted) wanteds
 754       Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds)
 755
 756 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 757 addIrred givens ct
 758   = addSCs (addToFM givens ct True) ct
 759
 760 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 761 addNonIrred givens ct
 762   = addSCs (addToFM givens ct False) ct
 763
 764 addSCs givens ct@(clas,tys)
 765  = foldl add givens sc_theta
 766  where
 767    (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
 768    sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl
 769
 770    add givens ct = case lookupFM givens ct of
 771                            Nothing    -> -- Add it and its superclasses
 772                                          addSCs (addToFM givens ct False) ct
 773
 774                            Just True  -> -- Set its flag to False; superclasses already done
 775                                          addToFM givens ct False
 776
 777                            Just False -> -- Already done
 778                                          givens
 779
 780 \end{code}
 781
 782 %************************************************************************
 783 %*                                                                      *
 784 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 785 %*                                                                      *
 786 %************************************************************************
 787
 788 When doing a binding group, we may have @Insts@ of local functions.
 789 For example, we might have...
 790 \begin{verbatim}
 791 let f x = x + 1     -- orig local function (overloaded)
 792     f.1 = f Int     -- two instances of f
 793     f.2 = f Float
 794  in
 795     (f.1 5, f.2 6.7)
 796 \end{verbatim}
 797 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 798 where @f@ is in scope; those @Insts@ must certainly not be passed
 799 upwards towards the top-level.  If the @Insts@ were binding-ified up
 800 there, they would have unresolvable references to @f@.
 801
 802 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 803 For each method @Inst@ in the @init_lie@ that mentions one of the
 804 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 805 @LIE@), as well as the @HsBinds@ generated.
 806
 807 \begin{code}
 808 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
 809
 810 bindInstsOfLocalFuns init_lie local_ids
 811   = reduceContext (text "bindInsts" <+> ppr local_ids)
 812                   try_me [] (bagToList init_lie)        `thenTc` \ (binds, frees, irreds) ->
 813     ASSERT( null irreds )
 814     returnTc (mkLIE frees, binds)
 815   where
 816     local_id_set = mkIdSet local_ids    -- There can occasionally be a lot of them
 817                                         -- so it's worth building a set, so that
 818                                         -- lookup (in isMethodFor) is faster
 819     try_me inst | isMethodFor local_id_set inst = ReduceMe CarryOn
 820                 | otherwise                     = Free
 821 \end{code}
 822
 823
 824 %************************************************************************
 825 %*                                                                      *
 826 \section[Disambig]{Disambiguation of overloading}
 827 %*                                                                      *
 828 %************************************************************************
 829
 830
 831 If a dictionary constrains a type variable which is
 832 \begin{itemize}
 833 \item
 834 not mentioned in the environment
 835 \item
 836 and not mentioned in the type of the expression
 837 \end{itemize}
 838 then it is ambiguous. No further information will arise to instantiate
 839 the type variable; nor will it be generalised and turned into an extra
 840 parameter to a function.
 841
 842 It is an error for this to occur, except that Haskell provided for
 843 certain rules to be applied in the special case of numeric types.
 844
 845 Specifically, if
 846 \begin{itemize}
 847 \item
 848 at least one of its classes is a numeric class, and
 849 \item
 850 all of its classes are numeric or standard
 851 \end{itemize}
 852 then the type variable can be defaulted to the first type in the
 853 default-type list which is an instance of all the offending classes.
 854
 855 So here is the function which does the work.  It takes the ambiguous
 856 dictionaries and either resolves them (producing bindings) or
 857 complains.  It works by splitting the dictionary list by type
 858 variable, and using @disambigOne@ to do the real business.
 859
 860
 861 @tcSimplifyTop@ is called once per module to simplify
 862 all the constant and ambiguous Insts.
 863
 864 \begin{code}
 865 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
 866 tcSimplifyTop wanteds
 867   = reduceContext (text "tcSimplTop") try_me [] (bagToList wanteds)     `thenTc` \ (binds1, frees, irreds) ->
 868     ASSERT( null frees )
 869
 870     let
 871                 -- All the non-std ones are definite errors
 872         (stds, non_stds) = partition isStdClassTyVarDict irreds
 873
 874
 875                 -- Group by type variable
 876         std_groups = equivClasses cmp_by_tyvar stds
 877
 878                 -- Pick the ones which its worth trying to disambiguate
 879         (std_oks, std_bads) = partition worth_a_try std_groups
 880                 -- Have a try at disambiguation
 881                 -- if the type variable isn't bound
 882                 -- up with one of the non-standard classes
 883         worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars)
 884         non_std_tyvars          = unionManyTyVarSets (map tyVarsOfInst non_stds)
 885
 886                 -- Collect together all the bad guys
 887         bad_guys = non_stds ++ concat std_bads
 888     in
 889
 890         -- Disambiguate the ones that look feasible
 891     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
 892
 893         -- And complain about the ones that don't
 894     mapNF_Tc complain bad_guys          `thenNF_Tc_`
 895
 896     returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
 897   where
 898     try_me inst          = ReduceMe AddToIrreds
 899
 900     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
 901
 902     complain d | isEmptyTyVarSet (tyVarsOfInst d) = addNoInstanceErr d
 903                | otherwise                        = addAmbigErr [d]
 904
 905 get_tv d   = case getDictClassTys d of
 906                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
 907 get_clas d = case getDictClassTys d of
 908                    (clas, [ty]) -> clas
 909 \end{code}
 910
 911 @disambigOne@ assumes that its arguments dictionaries constrain all
 912 the same type variable.
 913
 914 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
 915 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
 916 the most common use of defaulting is code like:
 917 \begin{verbatim}
 918         _ccall_ foo     `seqPrimIO` bar
 919 \end{verbatim}
 920 Since we're not using the result of @foo@, the result if (presumably)
 921 @void@.
 922
 923 \begin{code}
 924 disambigGroup :: [Inst s]       -- All standard classes of form (C a)
 925               -> TcM s (TcDictBinds s)
 926
 927 disambigGroup dicts
 928   |  any isNumericClass classes         -- Guaranteed all standard classes
 929   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 930         -- SO, TRY DEFAULT TYPES IN ORDER
 931
 932         -- Failure here is caused by there being no type in the
 933         -- default list which can satisfy all the ambiguous classes.
 934         -- For example, if Real a is reqd, but the only type in the
 935         -- default list is Int.
 936     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
 937     let
 938       try_default []    -- No defaults work, so fail
 939         = failTc
 940
 941       try_default (default_ty : default_tys)
 942         = tryTc (try_default default_tys) $     -- If default_ty fails, we try
 943                                                 -- default_tys instead
 944           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
 945           returnTc default_ty
 946         where
 947           thetas = classes `zip` repeat [default_ty]
 948     in
 949         -- See if any default works, and if so bind the type variable to it
 950         -- If not, add an AmbigErr
 951     recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds)  $
 952
 953     try_default default_tys                     `thenTc` \ chosen_default_ty ->
 954
 955         -- Bind the type variable and reduce the context, for real this time
 956     tcInstType emptyTyVarEnv chosen_default_ty          `thenNF_Tc` \ chosen_default_tc_ty ->   -- Tiresome!
 957     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)   `thenTc_`
 958     reduceContext (text "disambig" <+> ppr dicts)
 959                   try_me [] dicts       `thenTc` \ (binds, frees, ambigs) ->
 960     ASSERT( null frees && null ambigs )
 961     returnTc binds
 962
 963   | all isCcallishClass classes
 964   =     -- Default CCall stuff to (); we don't even both to check that () is an
 965         -- instance of CCallable/CReturnable, because we know it is.
 966     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
 967     returnTc EmptyMonoBinds
 968
 969   | otherwise -- No defaults
 970   = addAmbigErr dicts   `thenNF_Tc_`
 971     returnTc EmptyMonoBinds
 972
 973   where
 974     try_me inst = ReduceMe CarryOn
 975     tyvar       = get_tv (head dicts)           -- Should be non-empty
 976     classes     = map get_clas dicts
 977 \end{code}
 978
 979
 980
 981 Errors and contexts
 982 ~~~~~~~~~~~~~~~~~~~
 983 ToDo: for these error messages, should we note the location as coming
 984 from the insts, or just whatever seems to be around in the monad just
 985 now?
 986
 987 \begin{code}
 988 genCantGenErr insts     -- Can't generalise these Insts
 989   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
 990          nest 4 (pprInstsInFull insts)
 991         ]
 992
 993 addAmbigErr dicts
 994   = tcAddSrcLoc (instLoc (head dicts)) $
 995     addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts,
 996                    nest 4 (pprInstsInFull dicts)])
 997
 998 addNoInstanceErr dict
 999   = tcAddSrcLoc (instLoc dict)                 $
1000     tcAddErrCtxt (pprOrigin dict)              $
1001     addErrTc (noDictInstanceErr clas tys)
1002   where
1003     (clas, tys) = getDictClassTys dict
1004
1005 noDictInstanceErr clas tys
1006   = ptext SLIT("No instance for:") <+> quotes (pprConstraint clas tys)
1007
1008 reduceSigCtxt lie
1009   = sep [ptext SLIT("When matching against a type signature with context"),
1010          nest 4 (quotes (pprInsts (bagToList lie)))
1011     ]
1012 \end{code}
1013
1014