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