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