ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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, tcSimplifyToDicts,
 120         tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
 121         bindInstsOfLocalFuns
 122     ) where
 123
 124 #include "HsVersions.h"
 125
 126 import CmdLineOpts      ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
 127 import HsSyn            ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 128 import TcHsSyn          ( TcExpr, TcId,
 129                           TcMonoBinds, TcDictBinds
 130                         )
 131
 132 import TcMonad
 133 import Inst             ( lookupInst, lookupSimpleInst, LookupInstResult(..),
 134                           tyVarsOfInst,
 135                           isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
 136                           instToId, instBindingRequired, instCanBeGeneralised,
 137                           newDictFromOld,
 138                           getDictClassTys,
 139                           instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
 140                           Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
 141                           plusLIE
 142                         )
 143 import TcEnv            ( tcGetGlobalTyVars )
 144 import TcType           ( TcType, TcTyVarSet, typeToTcType )
 145 import TcUnify          ( unifyTauTy )
 146 import Id               ( idType )
 147 import Bag              ( bagToList )
 148 import Class            ( Class, classBigSig, classInstEnv )
 149 import PrelInfo         ( isNumericClass, isCreturnableClass, isCcallishClass )
 150
 151 import Type             ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
 152                           isTyVarTy, splitSigmaTy, tyVarsOfTypes
 153                         )
 154 import InstEnv          ( InstEnv )
 155 import Subst            ( mkTopTyVarSubst, substTheta )
 156 import PprType          ( pprConstraint )
 157 import TysWiredIn       ( unitTy )
 158 import VarSet
 159 import FiniteMap
 160 import BasicTypes       ( TopLevelFlag(..) )
 161 import CmdLineOpts      ( opt_GlasgowExts )
 162 import Outputable
 163 import Util
 164 import List             ( partition )
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection[tcSimplify-main]{Main entry function}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 175 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 176 top level defns we *do* squash constants, so that they stay local to a
 177 single defn.  This makes things which are inlined more likely to be
 178 exportable, because their constants are "inside".  Later passes will
 179 float them out if poss, after inlinings are sorted out.
 180
 181 \begin{code}
 182 tcSimplify
 183         :: SDoc
 184         -> TopLevelFlag
 185         -> TcTyVarSet                   -- ``Local''  type variables
 186                                         -- ASSERT: this tyvar set is already zonked
 187         -> LIE                          -- Wanted
 188         -> TcM s (LIE,                  -- Free
 189                   TcDictBinds,          -- Bindings
 190                   LIE)                  -- Remaining wanteds; no dups
 191
 192 tcSimplify str top_lvl local_tvs wanted_lie
 193   | isEmptyVarSet local_tvs
 194   = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
 195
 196   | otherwise
 197   = reduceContext str try_me [] wanteds         `thenTc` \ (binds, frees, irreds) ->
 198
 199         -- Check for non-generalisable insts
 200     let
 201         cant_generalise = filter (not . instCanBeGeneralised) irreds
 202     in
 203     checkTc (null cant_generalise)
 204             (genCantGenErr cant_generalise)     `thenTc_`
 205
 206         -- Check for ambiguous insts.
 207         -- You might think these can't happen (I did) because an ambiguous
 208         -- inst like (Eq a) will get tossed out with "frees", and eventually
 209         -- dealt with by tcSimplifyTop.
 210         -- But we can get stuck with
 211         --      C a b
 212         -- where "a" is one of the local_tvs, but "b" is unconstrained.
 213         -- Then we must yell about the ambiguous b
 214         -- But we must only do so if "b" really is unconstrained; so
 215         -- we must grab the global tyvars to answer that question
 216     tcGetGlobalTyVars                           `thenNF_Tc` \ global_tvs ->
 217     let
 218         avail_tvs           = local_tvs `unionVarSet` global_tvs
 219         (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
 220         ambig_tv_fn dict    = tyVarsOfInst dict `minusVarSet` avail_tvs
 221     in
 222     addAmbigErrs ambig_tv_fn bad_guys   `thenNF_Tc_`
 223
 224
 225         -- Finished
 226     returnTc (mkLIE frees, binds, mkLIE irreds')
 227   where
 228     -- the idea behind filtering out the dependencies here is that
 229     -- they've already served their purpose, and can be reconstructed
 230     -- at a later point from the retained class predicates.
 231     -- however, there *is* the possibility that a dependency
 232     -- out-lives the predicate from which it arose.
 233     -- I don't have any examples of this, but if they show up,
 234     -- we'd want to consider the possibility of saving the
 235     -- dependencies as hidden constraints (i.e. they'd only
 236     -- show up in interface files) -- or maybe they'd be useful
 237     -- as first class predicates...
 238     wanteds = filter notFunDep (bagToList wanted_lie)
 239
 240     try_me inst
 241       -- Does not constrain a local tyvar
 242       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 243       = -- if is_top_level then
 244         --   FreeIfTautological           -- Special case for inference on
 245         --                                -- top-level defns
 246         -- else
 247         Free
 248
 249       -- We're infering (not checking) the type, and
 250       -- the inst constrains a local type variable
 251       | isDict inst  = DontReduce               -- Dicts
 252       | otherwise    = ReduceMe AddToIrreds     -- Lits and Methods
 253 \end{code}
 254
 255 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 256 that there is an empty wanted-set at the end.  It may still return
 257 some of constant insts, which have to be resolved finally at the end.
 258
 259 \begin{code}
 260 tcSimplifyAndCheck
 261          :: SDoc
 262          -> TcTyVarSet          -- ``Local''  type variables
 263                                 -- ASSERT: this tyvar set is already zonked
 264          -> LIE                 -- Given; constrain only local tyvars
 265          -> LIE                 -- Wanted
 266          -> TcM s (LIE,         -- Free
 267                    TcDictBinds) -- Bindings
 268
 269 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
 270   | isEmptyVarSet local_tvs
 271         -- This can happen quite legitimately; for example in
 272         --      instance Num Int where ...
 273   = returnTc (wanted_lie, EmptyMonoBinds)
 274
 275   | otherwise
 276   = reduceContext str try_me givens wanteds     `thenTc` \ (binds, frees, irreds) ->
 277
 278         -- Complain about any irreducible ones
 279     mapNF_Tc complain irreds    `thenNF_Tc_`
 280
 281         -- Done
 282     returnTc (mkLIE frees, binds)
 283   where
 284     givens  = bagToList given_lie
 285     -- see comment on wanteds in tcSimplify
 286     wanteds = filter notFunDep (bagToList wanted_lie)
 287     given_dicts = filter isDict givens
 288
 289     try_me inst
 290       -- Does not constrain a local tyvar
 291       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 292       = Free
 293
 294       -- When checking against a given signature we always reduce
 295       -- until we find a match against something given, or can't reduce
 296       | otherwise
 297       = ReduceMe AddToIrreds
 298
 299     complain dict = mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 300                     addNoInstanceErr str given_dicts dict
 301 \end{code}
 302
 303 On the LHS of transformation rules we only simplify methods and constants,
 304 getting dictionaries.  We want to keep all of them unsimplified, to serve
 305 as the available stuff for the RHS of the rule.
 306
 307 The same thing is used for specialise pragmas. Consider
 308
 309         f :: Num a => a -> a
 310         {-# SPECIALISE f :: Int -> Int #-}
 311         f = ...
 312
 313 The type checker generates a binding like:
 314
 315         f_spec = (f :: Int -> Int)
 316
 317 and we want to end up with
 318
 319         f_spec = _inline_me_ (f Int dNumInt)
 320
 321 But that means that we must simplify the Method for f to (f Int dNumInt)!
 322 So tcSimplifyToDicts squeezes out all Methods.
 323
 324 \begin{code}
 325 tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
 326 tcSimplifyToDicts wanted_lie
 327   = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds  `thenTc` \ (binds, frees, irreds) ->
 328     ASSERT( null frees )
 329     returnTc (mkLIE irreds, binds)
 330   where
 331     -- see comment on wanteds in tcSimplify
 332     wanteds = filter notFunDep (bagToList wanted_lie)
 333
 334         -- Reduce methods and lits only; stop as soon as we get a dictionary
 335     try_me inst | isDict inst = DontReduce
 336                 | otherwise   = ReduceMe AddToIrreds
 337 \end{code}
 338
 339
 340
 341 %************************************************************************
 342 %*                                                                      *
 343 \subsection{Data types for the reduction mechanism}
 344 %*                                                                      *
 345 %************************************************************************
 346
 347 The main control over context reduction is here
 348
 349 \begin{code}
 350 data WhatToDo
 351  = ReduceMe               -- Try to reduce this
 352         NoInstanceAction  -- What to do if there's no such instance
 353
 354  | DontReduce             -- Return as irreducible
 355
 356  | Free                   -- Return as free
 357
 358  | FreeIfTautological     -- Return as free iff it's tautological;
 359                           -- if not, return as irreducible
 360         -- The FreeIfTautological case is to allow the possibility
 361         -- of generating functions with types like
 362         --      f :: C Int => Int -> Int
 363         -- Here, the C Int isn't a tautology presumably because Int
 364         -- isn't an instance of C in this module; but perhaps it will
 365         -- be at f's call site(s).  Haskell doesn't allow this at
 366         -- present.
 367
 368 data NoInstanceAction
 369   = Stop                -- Fail; no error message
 370                         -- (Only used when tautology checking.)
 371
 372   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 373                         -- produce an error message of any kind.
 374                         -- It might be quite legitimate such as (Eq a)!
 375 \end{code}
 376
 377
 378
 379 \begin{code}
 380 type RedState s
 381   = (Avails s,          -- What's available
 382      [Inst],            -- Insts for which try_me returned Free
 383      [Inst]             -- Insts for which try_me returned DontReduce
 384     )
 385
 386 type Avails s = FiniteMap Inst Avail
 387
 388 data Avail
 389   = Avail
 390         TcId            -- The "main Id"; that is, the Id for the Inst that
 391                         -- caused this avail to be put into the finite map in the first place
 392                         -- It is this Id that is bound to the RHS.
 393
 394         RHS             -- The RHS: an expression whose value is that Inst.
 395                         -- The main Id should be bound to this RHS
 396
 397         [TcId]  -- Extra Ids that must all be bound to the main Id.
 398                         -- At the end we generate a list of bindings
 399                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 400
 401 data RHS
 402   = NoRhs               -- Used for irreducible dictionaries,
 403                         -- which are going to be lambda bound, or for those that are
 404                         -- suppplied as "given" when checking againgst a signature.
 405                         --
 406                         -- NoRhs is also used for Insts like (CCallable f)
 407                         -- where no witness is required.
 408
 409   | Rhs                 -- Used when there is a RHS
 410         TcExpr
 411         Bool            -- True => the RHS simply selects a superclass dictionary
 412                         --         from a subclass dictionary.
 413                         -- False => not so.
 414                         -- This is useful info, because superclass selection
 415                         -- is cheaper than building the dictionary using its dfun,
 416                         -- and we can sometimes replace the latter with the former
 417
 418   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 419                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 420                         -- the finite map, with an PassiveScSel.  Then if the
 421                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 422         TcExpr
 423         [Inst]  -- List of Insts that are free in the RHS.
 424                         -- If the main Id is subsequently needed, we toss this list into
 425                         -- the needed-inst pool so that we make sure their bindings
 426                         -- will actually be produced.
 427                         --
 428                         -- Invariant: these Insts are already in the finite mapping
 429
 430
 431 pprAvails avails = vcat (map pp (eltsFM avails))
 432   where
 433     pp (Avail main_id rhs ids)
 434       = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 435
 436 pprRhs NoRhs = text "<no rhs>"
 437 pprRhs (Rhs rhs b) = ppr rhs
 438 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 439 \end{code}
 440
 441
 442 %************************************************************************
 443 %*                                                                      *
 444 \subsection[reduce]{@reduce@}
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 The main entry point for context reduction is @reduceContext@:
 449
 450 \begin{code}
 451 reduceContext :: SDoc -> (Inst -> WhatToDo)
 452               -> [Inst] -- Given
 453               -> [Inst] -- Wanted
 454               -> TcM s (TcDictBinds,
 455                         [Inst],         -- Free
 456                         [Inst])         -- Irreducible
 457
 458 reduceContext str try_me givens wanteds
 459   =     -- Zonking first
 460     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 461     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 462
 463 {-
 464     pprTrace "reduceContext" (vcat [
 465              text "----------------------",
 466              str,
 467              text "given" <+> ppr givens,
 468              text "wanted" <+> ppr wanteds,
 469              text "----------------------"
 470              ]) $
 471 -}
 472         -- Build the Avail mapping from "givens"
 473     foldlNF_Tc addGiven emptyFM givens          `thenNF_Tc` \ avails ->
 474
 475         -- Do the real work
 476     reduceList (0,[]) try_me wanteds (avails, [], [])   `thenTc` \ (avails, frees, irreds) ->
 477
 478         -- Extract the bindings from avails
 479     let
 480        binds = foldFM add_bind EmptyMonoBinds avails
 481
 482        add_bind _ (Avail main_id rhs ids) binds
 483          = foldr add_synonym (add_rhs_bind rhs binds) ids
 484          where
 485            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 486            add_rhs_bind other       binds = binds
 487
 488            -- Add the trivial {x = y} bindings
 489            -- The main Id can end up in the list when it's first added passively
 490            -- and then activated, so we have to filter it out.  A bit of a hack.
 491            add_synonym id binds
 492              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 493              | otherwise     = binds
 494     in
 495 {-
 496     pprTrace ("reduceContext end") (vcat [
 497              text "----------------------",
 498              str,
 499              text "given" <+> ppr givens,
 500              text "wanted" <+> ppr wanteds,
 501              text "----",
 502              text "avails" <+> pprAvails avails,
 503              text "irreds" <+> ppr irreds,
 504              text "----------------------"
 505              ]) $
 506 -}
 507     returnTc (binds, frees, irreds)
 508 \end{code}
 509
 510 The main context-reduction function is @reduce@.  Here's its game plan.
 511
 512 \begin{code}
 513 reduceList :: (Int,[Inst])              -- Stack (for err msgs)
 514                                         -- along with its depth
 515            -> (Inst -> WhatToDo)
 516            -> [Inst]
 517            -> RedState s
 518            -> TcM s (RedState s)
 519 \end{code}
 520
 521 @reduce@ is passed
 522      try_me:    given an inst, this function returns
 523                   Reduce       reduce this
 524                   DontReduce   return this in "irreds"
 525                   Free         return this in "frees"
 526
 527      wanteds:   The list of insts to reduce
 528      state:     An accumulating parameter of type RedState
 529                 that contains the state of the algorithm
 530
 531   It returns a RedState.
 532
 533 The (n,stack) pair is just used for error reporting.
 534 n is always the depth of the stack.
 535 The stack is the stack of Insts being reduced: to produce X
 536 I had to produce Y, to produce Y I had to produce Z, and so on.
 537
 538 \begin{code}
 539 reduceList (n,stack) try_me wanteds state
 540   | n > opt_MaxContextReductionDepth
 541   = failWithTc (reduceDepthErr n stack)
 542
 543   | otherwise
 544   =
 545 #ifdef DEBUG
 546    (if n > 8 then
 547         pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
 548     else (\x->x))
 549 #endif
 550     go wanteds state
 551   where
 552     go []     state = returnTc state
 553     go (w:ws) state = reduce (n+1, w:stack) try_me w state      `thenTc` \ state' ->
 554                       go ws state'
 555
 556     -- Base case: we're done!
 557 reduce stack try_me wanted state@(avails, frees, irreds)
 558     -- It's the same as an existing inst, or a superclass thereof
 559   | wanted `elemFM` avails
 560   = returnTc (activate avails wanted, frees, irreds)
 561
 562   | otherwise
 563   = case try_me wanted of {
 564
 565     ReduceMe no_instance_action ->      -- It should be reduced
 566         lookupInst wanted             `thenNF_Tc` \ lookup_result ->
 567         case lookup_result of
 568             GenInst wanteds' rhs -> use_instance wanteds' rhs
 569             SimpleInst rhs       -> use_instance []       rhs
 570
 571             NoInstance ->    -- No such instance!
 572                     case no_instance_action of
 573                         Stop        -> failTc
 574                         AddToIrreds -> add_to_irreds
 575     ;
 576     Free ->     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 577                 -- First, see if the inst can be reduced to a constant in one step
 578         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 579         case lookup_result of
 580             SimpleInst rhs -> use_instance [] rhs
 581             other          -> add_to_frees
 582
 583
 584
 585     ;
 586     FreeIfTautological -> -- It's free and this is a top level binding, so
 587                           -- check whether it's a tautology or not
 588         tryTc_
 589           add_to_irreds   -- If tautology trial fails, add to irreds
 590
 591           -- If tautology succeeds, just add to frees
 592           (reduce stack try_me_taut wanted (avails, [], [])     `thenTc_`
 593            returnTc (avails, wanted:frees, irreds))
 594
 595
 596     ;
 597     DontReduce ->    -- It's irreducible (or at least should not be reduced)
 598         -- See if the inst can be reduced to a constant in one step
 599         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 600         case lookup_result of
 601            SimpleInst rhs -> use_instance [] rhs
 602            other          -> add_to_irreds
 603     }
 604   where
 605         -- The three main actions
 606     add_to_frees  = let
 607                         avails' = addFree avails wanted
 608                         -- Add the thing to the avails set so any identical Insts
 609                         -- will be commoned up with it right here
 610                     in
 611                     returnTc (avails', wanted:frees, irreds)
 612
 613     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 614                     returnTc (avails',  frees, wanted:irreds)
 615
 616     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 617                                 reduceList stack try_me wanteds' (avails', frees, irreds)
 618
 619
 620     -- The try-me to use when trying to identify tautologies
 621     -- It blunders on reducing as much as possible
 622     try_me_taut inst = ReduceMe Stop    -- No error recovery
 623 \end{code}
 624
 625
 626 \begin{code}
 627 activate :: Avails s -> Inst -> Avails s
 628          -- Activate the binding for Inst, ensuring that a binding for the
 629          -- wanted Inst will be generated.
 630          -- (Activate its parent if necessary, recursively).
 631          -- Precondition: the Inst is in Avails already
 632
 633 activate avails wanted
 634   | not (instBindingRequired wanted)
 635   = avails
 636
 637   | otherwise
 638   = case lookupFM avails wanted of
 639
 640       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 641                foldl activate avails' insts      -- Activate anything it needs
 642              where
 643                avails' = addToFM avails wanted avail'
 644                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 645
 646       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 647                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 648
 649       Nothing -> panic "activate"
 650   where
 651       wanted_id = instToId wanted
 652
 653 addWanted avails wanted rhs_expr
 654   = ASSERT( not (wanted `elemFM` avails) )
 655     returnNF_Tc (addToFM avails wanted avail)
 656         -- NB: we don't add the thing's superclasses too!
 657         -- Why not?  Because addWanted is used when we've successfully used an
 658         -- instance decl to reduce something; e.g.
 659         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 660         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 661         -- If we put the superclasses of "d" in avails, then we might end up
 662         -- expressing "d1" in terms of "d", which would be a disaster.
 663   where
 664     avail = Avail (instToId wanted) rhs []
 665
 666     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 667         | otherwise                  = NoRhs
 668
 669 addFree :: Avails s -> Inst -> (Avails s)
 670         -- When an Inst is tossed upstairs as 'free' we nevertheless add it
 671         -- to avails, so that any other equal Insts will be commoned up right
 672         -- here rather than also being tossed upstairs.  This is really just
 673         -- an optimisation, and perhaps it is more trouble that it is worth,
 674         -- as the following comments show!
 675         --
 676         -- NB1: do *not* add superclasses.  If we have
 677         --      df::Floating a
 678         --      dn::Num a
 679         -- but a is not bound here, then we *don't* want to derive
 680         -- dn from df here lest we lose sharing.
 681         --
 682         -- NB2: do *not* add the Inst to avails at all if it's a method.
 683         -- The following situation shows why this is bad:
 684         --      truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
 685         -- From an application (truncate f i) we get
 686         --      t1 = truncate at f
 687         --      t2 = t1 at i
 688         -- If we have also have a secon occurrence of truncate, we get
 689         --      t3 = truncate at f
 690         --      t4 = t3 at i
 691         -- When simplifying with i,f free, we might still notice that
 692         --   t1=t3; but alas, the binding for t2 (which mentions t1)
 693         --   will continue to float out!
 694         -- Solution: never put methods in avail till they are captured
 695         -- in which case addFree isn't used
 696 addFree avails free
 697   | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
 698   | otherwise   = avails
 699
 700 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
 701 addGiven avails given
 702   =      -- ASSERT( not (given `elemFM` avails) )
 703          -- This assertion isn't necessarily true.  It's permitted
 704          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 705          -- and when typechecking instance decls we generate redundant "givens" too.
 706     addAvail avails given avail
 707   where
 708     avail = Avail (instToId given) NoRhs []
 709
 710 addAvail avails wanted avail
 711   = addSuperClasses (addToFM avails wanted avail) wanted
 712
 713 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
 714                 -- Add all the superclasses of the Inst to Avails
 715                 -- Invariant: the Inst is already in Avails.
 716
 717 addSuperClasses avails dict
 718   | not (isDict dict)
 719   = returnNF_Tc avails
 720
 721   | otherwise   -- It is a dictionary
 722   = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
 723   where
 724     (clas, tys) = getDictClassTys dict
 725
 726     (tyvars, sc_theta, sc_sels, _) = classBigSig clas
 727     sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
 728
 729     add_sc avails ((super_clas, super_tys), sc_sel)
 730       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 731         let
 732            sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
 733                                 [instToId dict]
 734         in
 735         case lookupFM avails super_dict of
 736
 737              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 738                   -- Already there, but not as a superclass selector
 739                   -- No need to look at its superclasses; since it's there
 740                   --    already they must be already in avails
 741                   -- However, we must remember to activate the dictionary
 742                   -- from which it is (now) generated
 743                   returnNF_Tc (activate avails' dict)
 744                 where
 745                   avails' = addToFM avails super_dict avail
 746                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 747
 748              Just (Avail _ _ _) -> returnNF_Tc avails
 749                   -- Already there; no need to do anything
 750
 751              Nothing ->
 752                   -- Not there at all, so add it, and its superclasses
 753                   addAvail avails super_dict avail
 754                 where
 755                   avail   = Avail (instToId super_dict)
 756                                   (PassiveScSel sc_sel_rhs [dict])
 757                                   []
 758 \end{code}
 759
 760 %************************************************************************
 761 %*                                                                      *
 762 \subsection[simple]{@Simple@ versions}
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 Much simpler versions when there are no bindings to make!
 767
 768 @tcSimplifyThetas@ simplifies class-type constraints formed by
 769 @deriving@ declarations and when specialising instances.  We are
 770 only interested in the simplified bunch of class/type constraints.
 771
 772 It simplifies to constraints of the form (C a b c) where
 773 a,b,c are type variables.  This is required for the context of
 774 instance declarations.
 775
 776 \begin{code}
 777 tcSimplifyThetas :: (Class -> InstEnv)          -- How to find the InstEnv
 778                  -> ThetaType                   -- Wanted
 779                  -> TcM s ThetaType             -- Needed
 780
 781 tcSimplifyThetas inst_mapper wanteds
 782   = reduceSimple inst_mapper [] wanteds         `thenNF_Tc` \ irreds ->
 783     let
 784         -- For multi-param Haskell, check that the returned dictionaries
 785         -- don't have any of the form (C Int Bool) for which
 786         -- we expect an instance here
 787         -- For Haskell 98, check that all the constraints are of the form C a,
 788         -- where a is a type variable
 789         bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
 790                                            isEmptyVarSet (tyVarsOfTypes tys)]
 791                  | otherwise       = [ct | ct@(clas,tys) <- irreds,
 792                                            not (all isTyVarTy tys)]
 793     in
 794     if null bad_guys then
 795         returnTc irreds
 796     else
 797        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 798        failTc
 799 \end{code}
 800
 801 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 802 used with \tr{default} declarations.  We are only interested in
 803 whether it worked or not.
 804
 805 \begin{code}
 806 tcSimplifyCheckThetas :: ThetaType      -- Given
 807                       -> ThetaType      -- Wanted
 808                       -> TcM s ()
 809
 810 tcSimplifyCheckThetas givens wanteds
 811   = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`     \ irreds ->
 812     if null irreds then
 813        returnTc ()
 814     else
 815        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 816        failTc
 817 \end{code}
 818
 819
 820 \begin{code}
 821 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
 822                     -- True  => irreducible
 823                     -- False => given, or can be derived from a given or from an irreducible
 824
 825 reduceSimple :: (Class -> InstEnv)
 826              -> ThetaType               -- Given
 827              -> ThetaType               -- Wanted
 828              -> NF_TcM s ThetaType      -- Irreducible
 829
 830 reduceSimple inst_mapper givens wanteds
 831   = reduce_simple (0,[]) inst_mapper givens_fm wanteds  `thenNF_Tc` \ givens_fm' ->
 832     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 833   where
 834     givens_fm     = foldl addNonIrred emptyFM givens
 835
 836 reduce_simple :: (Int,ThetaType)                -- Stack
 837               -> (Class -> InstEnv)
 838               -> AvailsSimple
 839               -> ThetaType
 840               -> NF_TcM s AvailsSimple
 841
 842 reduce_simple (n,stack) inst_mapper avails wanteds
 843   = go avails wanteds
 844   where
 845     go avails []     = returnNF_Tc avails
 846     go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w    `thenNF_Tc` \ avails' ->
 847                        go avails' ws
 848
 849 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
 850   | wanted `elemFM` givens
 851   = returnNF_Tc givens
 852
 853   | otherwise
 854   = lookupSimpleInst (inst_mapper clas) clas tys        `thenNF_Tc` \ maybe_theta ->
 855
 856     case maybe_theta of
 857       Nothing ->    returnNF_Tc (addIrred givens wanted)
 858       Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
 859
 860 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 861 addIrred givens ct
 862   = addSCs (addToFM givens ct True) ct
 863
 864 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 865 addNonIrred givens ct
 866   = addSCs (addToFM givens ct False) ct
 867
 868 addSCs givens ct@(clas,tys)
 869  = foldl add givens sc_theta
 870  where
 871    (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
 872    sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
 873
 874    add givens ct = case lookupFM givens ct of
 875                            Nothing    -> -- Add it and its superclasses
 876                                          addSCs (addToFM givens ct False) ct
 877
 878                            Just True  -> -- Set its flag to False; superclasses already done
 879                                          addToFM givens ct False
 880
 881                            Just False -> -- Already done
 882                                          givens
 883
 884 \end{code}
 885
 886 %************************************************************************
 887 %*                                                                      *
 888 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 889 %*                                                                      *
 890 %************************************************************************
 891
 892 When doing a binding group, we may have @Insts@ of local functions.
 893 For example, we might have...
 894 \begin{verbatim}
 895 let f x = x + 1     -- orig local function (overloaded)
 896     f.1 = f Int     -- two instances of f
 897     f.2 = f Float
 898  in
 899     (f.1 5, f.2 6.7)
 900 \end{verbatim}
 901 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 902 where @f@ is in scope; those @Insts@ must certainly not be passed
 903 upwards towards the top-level.  If the @Insts@ were binding-ified up
 904 there, they would have unresolvable references to @f@.
 905
 906 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 907 For each method @Inst@ in the @init_lie@ that mentions one of the
 908 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 909 @LIE@), as well as the @HsBinds@ generated.
 910
 911 \begin{code}
 912 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
 913
 914 bindInstsOfLocalFuns init_lie local_ids
 915   | null overloaded_ids || null lie_for_here
 916         -- Common case
 917   = returnTc (init_lie, EmptyMonoBinds)
 918
 919   | otherwise
 920   = reduceContext (text "bindInsts" <+> ppr local_ids)
 921                   try_me [] lie_for_here        `thenTc` \ (binds, frees, irreds) ->
 922     ASSERT( null irreds )
 923     returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
 924   where
 925     overloaded_ids = filter is_overloaded local_ids
 926     is_overloaded id = case splitSigmaTy (idType id) of
 927                           (_, theta, _) -> not (null theta)
 928
 929     overloaded_set = mkVarSet overloaded_ids    -- There can occasionally be a lot of them
 930                                                 -- so it's worth building a set, so that
 931                                                 -- lookup (in isMethodFor) is faster
 932
 933         -- No sense in repeatedly zonking lots of
 934         -- constant constraints so filter them out here
 935     (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
 936                                                  (bagToList init_lie)
 937     try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
 938                 | otherwise                       = Free
 939 \end{code}
 940
 941
 942 %************************************************************************
 943 %*                                                                      *
 944 \section[Disambig]{Disambiguation of overloading}
 945 %*                                                                      *
 946 %************************************************************************
 947
 948
 949 If a dictionary constrains a type variable which is
 950 \begin{itemize}
 951 \item
 952 not mentioned in the environment
 953 \item
 954 and not mentioned in the type of the expression
 955 \end{itemize}
 956 then it is ambiguous. No further information will arise to instantiate
 957 the type variable; nor will it be generalised and turned into an extra
 958 parameter to a function.
 959
 960 It is an error for this to occur, except that Haskell provided for
 961 certain rules to be applied in the special case of numeric types.
 962
 963 Specifically, if
 964 \begin{itemize}
 965 \item
 966 at least one of its classes is a numeric class, and
 967 \item
 968 all of its classes are numeric or standard
 969 \end{itemize}
 970 then the type variable can be defaulted to the first type in the
 971 default-type list which is an instance of all the offending classes.
 972
 973 So here is the function which does the work.  It takes the ambiguous
 974 dictionaries and either resolves them (producing bindings) or
 975 complains.  It works by splitting the dictionary list by type
 976 variable, and using @disambigOne@ to do the real business.
 977
 978
 979 @tcSimplifyTop@ is called once per module to simplify
 980 all the constant and ambiguous Insts.
 981
 982 \begin{code}
 983 tcSimplifyTop :: LIE -> TcM s TcDictBinds
 984 tcSimplifyTop wanted_lie
 985   = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
 986     ASSERT( null frees )
 987
 988     let
 989                 -- All the non-std ones are definite errors
 990         (stds, non_stds) = partition isStdClassTyVarDict irreds
 991
 992
 993                 -- Group by type variable
 994         std_groups = equivClasses cmp_by_tyvar stds
 995
 996                 -- Pick the ones which its worth trying to disambiguate
 997         (std_oks, std_bads) = partition worth_a_try std_groups
 998                 -- Have a try at disambiguation
 999                 -- if the type variable isn't bound
1000                 -- up with one of the non-standard classes
1001         worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
1002         non_std_tyvars          = unionVarSets (map tyVarsOfInst non_stds)
1003
1004                 -- Collect together all the bad guys
1005         bad_guys = non_stds ++ concat std_bads
1006     in
1007
1008         -- Disambiguate the ones that look feasible
1009     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
1010
1011         -- And complain about the ones that don't
1012     mapNF_Tc complain bad_guys          `thenNF_Tc_`
1013
1014     returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1015   where
1016     -- see comment on wanteds in tcSimplify
1017     wanteds     = filter notFunDep (bagToList wanted_lie)
1018     try_me inst = ReduceMe AddToIrreds
1019
1020     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1021
1022     complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1023                | otherwise                      = addAmbigErr tyVarsOfInst d
1024
1025 get_tv d   = case getDictClassTys d of
1026                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1027 get_clas d = case getDictClassTys d of
1028                    (clas, [ty]) -> clas
1029 \end{code}
1030
1031 @disambigOne@ assumes that its arguments dictionaries constrain all
1032 the same type variable.
1033
1034 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1035 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
1036 the most common use of defaulting is code like:
1037 \begin{verbatim}
1038         _ccall_ foo     `seqPrimIO` bar
1039 \end{verbatim}
1040 Since we're not using the result of @foo@, the result if (presumably)
1041 @void@.
1042
1043 \begin{code}
1044 disambigGroup :: [Inst] -- All standard classes of form (C a)
1045               -> TcM s TcDictBinds
1046
1047 disambigGroup dicts
1048   |   any isNumericClass classes        -- Guaranteed all standard classes
1049           -- see comment at the end of function for reasons as to
1050           -- why the defaulting mechanism doesn't apply to groups that
1051           -- include CCallable or CReturnable dicts.
1052    && not (any isCcallishClass classes)
1053   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1054         -- SO, TRY DEFAULT TYPES IN ORDER
1055
1056         -- Failure here is caused by there being no type in the
1057         -- default list which can satisfy all the ambiguous classes.
1058         -- For example, if Real a is reqd, but the only type in the
1059         -- default list is Int.
1060     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
1061     let
1062       try_default []    -- No defaults work, so fail
1063         = failTc
1064
1065       try_default (default_ty : default_tys)
1066         = tryTc_ (try_default default_tys) $    -- If default_ty fails, we try
1067                                                 -- default_tys instead
1068           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
1069           returnTc default_ty
1070         where
1071           thetas = classes `zip` repeat [default_ty]
1072     in
1073         -- See if any default works, and if so bind the type variable to it
1074         -- If not, add an AmbigErr
1075     recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds)     $
1076
1077     try_default default_tys                     `thenTc` \ chosen_default_ty ->
1078
1079         -- Bind the type variable and reduce the context, for real this time
1080     let
1081         chosen_default_tc_ty = typeToTcType chosen_default_ty   -- Tiresome!
1082     in
1083     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)   `thenTc_`
1084     reduceContext (text "disambig" <+> ppr dicts)
1085                   try_me [] dicts                       `thenTc` \ (binds, frees, ambigs) ->
1086     ASSERT( null frees && null ambigs )
1087     warnDefault dicts chosen_default_ty                 `thenTc_`
1088     returnTc binds
1089
1090   | all isCreturnableClass classes
1091   =     -- Default CCall stuff to (); we don't even both to check that () is an
1092         -- instance of CReturnable, because we know it is.
1093     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
1094     returnTc EmptyMonoBinds
1095
1096   | otherwise -- No defaults
1097   = complain dicts      `thenNF_Tc_`
1098     returnTc EmptyMonoBinds
1099
1100   where
1101     complain    = addAmbigErrs tyVarsOfInst
1102     try_me inst = ReduceMe AddToIrreds          -- This reduce should not fail
1103     tyvar       = get_tv (head dicts)           -- Should be non-empty
1104     classes     = map get_clas dicts
1105 \end{code}
1106
1107 [Aside - why the defaulting mechanism is turned off when
1108  dealing with arguments and results to ccalls.
1109
1110 When typechecking _ccall_s, TcExpr ensures that the external
1111 function is only passed arguments (and in the other direction,
1112 results) of a restricted set of 'native' types. This is
1113 implemented via the help of the pseudo-type classes,
1114 @CReturnable@ (CR) and @CCallable@ (CC.)
1115
1116 The interaction between the defaulting mechanism for numeric
1117 values and CC & CR can be a bit puzzling to the user at times.
1118 For example,
1119
1120     x <- _ccall_ f
1121     if (x /= 0) then
1122        _ccall_ g x
1123      else
1124        return ()
1125
1126 What type has 'x' got here? That depends on the default list
1127 in operation, if it is equal to Haskell 98's default-default
1128 of (Integer, Double), 'x' has type Double, since Integer
1129 is not an instance of CR. If the default list is equal to
1130 Haskell 1.4's default-default of (Int, Double), 'x' has type
1131 Int.
1132
1133 To try to minimise the potential for surprises here, the
1134 defaulting mechanism is turned off in the presence of
1135 CCallable and CReturnable.
1136
1137 ]
1138
1139 Errors and contexts
1140 ~~~~~~~~~~~~~~~~~~~
1141 ToDo: for these error messages, should we note the location as coming
1142 from the insts, or just whatever seems to be around in the monad just
1143 now?
1144
1145 \begin{code}
1146 genCantGenErr insts     -- Can't generalise these Insts
1147   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1148          nest 4 (pprInstsInFull insts)
1149         ]
1150
1151 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1152
1153 addAmbigErr ambig_tv_fn dict
1154   = addInstErrTcM (instLoc dict)
1155         (tidy_env,
1156          sep [text "Ambiguous type variable(s)" <+>
1157                         hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1158               nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1159   where
1160     ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1161     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1162
1163 warnDefault dicts default_ty
1164   | not opt_WarnTypeDefaults
1165   = returnNF_Tc ()
1166
1167   | otherwise
1168   = warnTc True msg
1169   where
1170     msg | length dicts > 1
1171         = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1172           $$ pprInstsInFull tidy_dicts
1173         | otherwise
1174         = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1175           ptext SLIT("to type") <+> quotes (ppr default_ty)
1176
1177     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1178
1179 addRuleLhsErr dict
1180   = addInstErrTcM (instLoc dict)
1181         (tidy_env,
1182          vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1183                nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
1184   where
1185     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1186
1187 -- Used for top-level irreducibles
1188 addTopInstanceErr dict
1189   = addInstErrTcM (instLoc dict)
1190         (tidy_env,
1191          ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1192   where
1193     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1194
1195 addNoInstanceErr str givens dict
1196   = addInstErrTcM (instLoc dict)
1197         (tidy_env,
1198          sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1199               nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1200         $$
1201          ptext SLIT("Probable cause:") <+>
1202               vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1203                     ptext SLIT("in") <+> str],
1204                     if all_tyvars then empty else
1205                     ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1206     )
1207   where
1208     all_tyvars = all isTyVarTy tys
1209     (_, tys)   = getDictClassTys dict
1210     (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1211
1212 -- Used for the ...Thetas variants; all top level
1213 addNoInstErr (c,ts)
1214   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1215
1216 reduceDepthErr n stack
1217   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1218           ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1219           nest 4 (pprInstsInFull stack)]
1220
1221 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
1222 \end{code}