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