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