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