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