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