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,
 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
 145                         )
 146 import TcEnv            ( tcGetGlobalTyVars, tcGetInstEnv,
 147                           lookupInstEnv, InstLookupResult(..)
 148                         )
 149 import TcType           ( TcTyVarSet )
 150 import TcUnify          ( unifyTauTy )
 151 import Id               ( idType )
 152 import Class            ( Class, classBigSig )
 153 import PrelInfo         ( isNumericClass, isCreturnableClass, isCcallishClass )
 154
 155 import Type             ( Type, 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 CmdLineOpts      ( opt_GlasgowExts )
 165 import Outputable
 166 import ListSetOps       ( equivClasses )
 167 import Util             ( zipEqual, mapAccumL )
 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     addFunDeps (addToFM avails wanted avail) wanted
 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) `thenNF_Tc` \ avails' ->
 784     addFunDeps avails' dict
 785   where
 786     (clas, tys) = getDictClassTys dict
 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
 820 addFunDeps :: Avails s -> Inst -> NF_TcM s (Avails s)
 821            -- Add in the functional dependencies generated by the inst
 822 addFunDeps avails inst
 823   = newFunDepFromDict inst      `thenNF_Tc` \ fdInst_maybe ->
 824     case fdInst_maybe of
 825       Nothing -> returnNF_Tc avails
 826       Just fdInst ->
 827         let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
 828         addAvail avails fdInst fdAvail
 829 \end{code}
 830
 831 %************************************************************************
 832 %*                                                                      *
 833 \subsection[simple]{@Simple@ versions}
 834 %*                                                                      *
 835 %************************************************************************
 836
 837 Much simpler versions when there are no bindings to make!
 838
 839 @tcSimplifyThetas@ simplifies class-type constraints formed by
 840 @deriving@ declarations and when specialising instances.  We are
 841 only interested in the simplified bunch of class/type constraints.
 842
 843 It simplifies to constraints of the form (C a b c) where
 844 a,b,c are type variables.  This is required for the context of
 845 instance declarations.
 846
 847 \begin{code}
 848 tcSimplifyThetas :: ClassContext                -- Wanted
 849                  -> TcM s ClassContext          -- Needed
 850
 851 tcSimplifyThetas wanteds
 852   = reduceSimple [] wanteds             `thenNF_Tc` \ irreds ->
 853     let
 854         -- For multi-param Haskell, check that the returned dictionaries
 855         -- don't have any of the form (C Int Bool) for which
 856         -- we expect an instance here
 857         -- For Haskell 98, check that all the constraints are of the form C a,
 858         -- where a is a type variable
 859         bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
 860                                            isEmptyVarSet (tyVarsOfTypes tys)]
 861                  | otherwise       = [ct | ct@(clas,tys) <- irreds,
 862                                            not (all isTyVarTy tys)]
 863     in
 864     if null bad_guys then
 865         returnTc irreds
 866     else
 867        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 868        failTc
 869 \end{code}
 870
 871 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 872 used with \tr{default} declarations.  We are only interested in
 873 whether it worked or not.
 874
 875 \begin{code}
 876 tcSimplifyCheckThetas :: ClassContext   -- Given
 877                       -> ClassContext   -- Wanted
 878                       -> TcM s ()
 879
 880 tcSimplifyCheckThetas givens wanteds
 881   = reduceSimple givens wanteds    `thenNF_Tc`  \ irreds ->
 882     if null irreds then
 883        returnTc ()
 884     else
 885        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 886        failTc
 887 \end{code}
 888
 889
 890 \begin{code}
 891 type AvailsSimple = FiniteMap (Class,[Type]) Bool
 892                     -- True  => irreducible
 893                     -- False => given, or can be derived from a given or from an irreducible
 894
 895 reduceSimple :: ClassContext                    -- Given
 896              -> ClassContext                    -- Wanted
 897              -> NF_TcM s ClassContext           -- Irreducible
 898
 899 reduceSimple givens wanteds
 900   = reduce_simple (0,[]) givens_fm wanteds      `thenNF_Tc` \ givens_fm' ->
 901     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 902   where
 903     givens_fm     = foldl addNonIrred emptyFM givens
 904
 905 reduce_simple :: (Int,ClassContext)             -- Stack
 906               -> AvailsSimple
 907               -> ClassContext
 908               -> NF_TcM s AvailsSimple
 909
 910 reduce_simple (n,stack) avails wanteds
 911   = go avails wanteds
 912   where
 913     go avails []     = returnNF_Tc avails
 914     go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w        `thenNF_Tc` \ avails' ->
 915                        go avails' ws
 916
 917 reduce_simple_help stack givens wanted@(clas,tys)
 918   | wanted `elemFM` givens
 919   = returnNF_Tc givens
 920
 921   | otherwise
 922   = lookupSimpleInst clas tys   `thenNF_Tc` \ maybe_theta ->
 923
 924     case maybe_theta of
 925       Nothing ->    returnNF_Tc (addIrred givens wanted)
 926       Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
 927
 928 addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
 929 addIrred givens ct@(clas,tys)
 930   = addSCs (addToFM givens ct True) ct
 931
 932 addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
 933 addNonIrred givens ct@(clas,tys)
 934   = addSCs (addToFM givens ct False) ct
 935
 936 addSCs givens ct@(clas,tys)
 937  = foldl add givens sc_theta
 938  where
 939    (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
 940    sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
 941
 942    add givens ct@(clas, tys)
 943      = case lookupFM givens ct of
 944        Nothing    -> -- Add it and its superclasses
 945                      addSCs (addToFM givens ct False) ct
 946
 947        Just True  -> -- Set its flag to False; superclasses already done
 948                      addToFM givens ct False
 949
 950        Just False -> -- Already done
 951                      givens
 952
 953 \end{code}
 954
 955 %************************************************************************
 956 %*                                                                      *
 957 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 958 %*                                                                      *
 959 %************************************************************************
 960
 961 When doing a binding group, we may have @Insts@ of local functions.
 962 For example, we might have...
 963 \begin{verbatim}
 964 let f x = x + 1     -- orig local function (overloaded)
 965     f.1 = f Int     -- two instances of f
 966     f.2 = f Float
 967  in
 968     (f.1 5, f.2 6.7)
 969 \end{verbatim}
 970 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 971 where @f@ is in scope; those @Insts@ must certainly not be passed
 972 upwards towards the top-level.  If the @Insts@ were binding-ified up
 973 there, they would have unresolvable references to @f@.
 974
 975 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 976 For each method @Inst@ in the @init_lie@ that mentions one of the
 977 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 978 @LIE@), as well as the @HsBinds@ generated.
 979
 980 \begin{code}
 981 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
 982
 983 bindInstsOfLocalFuns init_lie local_ids
 984   | null overloaded_ids || null lie_for_here
 985         -- Common case
 986   = returnTc (init_lie, EmptyMonoBinds)
 987
 988   | otherwise
 989   = reduceContext (text "bindInsts" <+> ppr local_ids)
 990                   try_me [] lie_for_here        `thenTc` \ (binds, frees, irreds) ->
 991     ASSERT( null irreds )
 992     returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
 993   where
 994     overloaded_ids = filter is_overloaded local_ids
 995     is_overloaded id = case splitSigmaTy (idType id) of
 996                           (_, theta, _) -> not (null theta)
 997
 998     overloaded_set = mkVarSet overloaded_ids    -- There can occasionally be a lot of them
 999                                                 -- so it's worth building a set, so that
1000                                                 -- lookup (in isMethodFor) is faster
1001
1002         -- No sense in repeatedly zonking lots of
1003         -- constant constraints so filter them out here
1004     (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
1005                                                  (lieToList init_lie)
1006     try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
1007                 | otherwise                       = Free
1008 \end{code}
1009
1010
1011 %************************************************************************
1012 %*                                                                      *
1013 \section[Disambig]{Disambiguation of overloading}
1014 %*                                                                      *
1015 %************************************************************************
1016
1017
1018 If a dictionary constrains a type variable which is
1019 \begin{itemize}
1020 \item
1021 not mentioned in the environment
1022 \item
1023 and not mentioned in the type of the expression
1024 \end{itemize}
1025 then it is ambiguous. No further information will arise to instantiate
1026 the type variable; nor will it be generalised and turned into an extra
1027 parameter to a function.
1028
1029 It is an error for this to occur, except that Haskell provided for
1030 certain rules to be applied in the special case of numeric types.
1031
1032 Specifically, if
1033 \begin{itemize}
1034 \item
1035 at least one of its classes is a numeric class, and
1036 \item
1037 all of its classes are numeric or standard
1038 \end{itemize}
1039 then the type variable can be defaulted to the first type in the
1040 default-type list which is an instance of all the offending classes.
1041
1042 So here is the function which does the work.  It takes the ambiguous
1043 dictionaries and either resolves them (producing bindings) or
1044 complains.  It works by splitting the dictionary list by type
1045 variable, and using @disambigOne@ to do the real business.
1046
1047
1048 @tcSimplifyTop@ is called once per module to simplify
1049 all the constant and ambiguous Insts.
1050
1051 \begin{code}
1052 tcSimplifyTop :: LIE -> TcM s TcDictBinds
1053 tcSimplifyTop wanted_lie
1054   = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
1055     ASSERT( null frees )
1056
1057     let
1058                 -- All the non-std ones are definite errors
1059         (stds, non_stds) = partition isStdClassTyVarDict irreds
1060
1061
1062                 -- Group by type variable
1063         std_groups = equivClasses cmp_by_tyvar stds
1064
1065                 -- Pick the ones which its worth trying to disambiguate
1066         (std_oks, std_bads) = partition worth_a_try std_groups
1067                 -- Have a try at disambiguation
1068                 -- if the type variable isn't bound
1069                 -- up with one of the non-standard classes
1070         worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
1071         non_std_tyvars          = unionVarSets (map tyVarsOfInst non_stds)
1072
1073                 -- Collect together all the bad guys
1074         bad_guys = non_stds ++ concat std_bads
1075     in
1076
1077         -- Disambiguate the ones that look feasible
1078     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
1079
1080         -- And complain about the ones that don't
1081     mapNF_Tc complain bad_guys          `thenNF_Tc_`
1082
1083     returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1084   where
1085     wanteds     = lieToList wanted_lie
1086     try_me inst = ReduceMe AddToIrreds
1087
1088     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1089
1090     complain d | not (null (getIPs d))          = addTopIPErr d
1091                | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1092                | otherwise                      = addAmbigErr tyVarsOfInst d
1093
1094 get_tv d   = case getDictClassTys d of
1095                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1096 get_clas d = case getDictClassTys d of
1097                    (clas, [ty]) -> clas
1098 \end{code}
1099
1100 @disambigOne@ assumes that its arguments dictionaries constrain all
1101 the same type variable.
1102
1103 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1104 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
1105 the most common use of defaulting is code like:
1106 \begin{verbatim}
1107         _ccall_ foo     `seqPrimIO` bar
1108 \end{verbatim}
1109 Since we're not using the result of @foo@, the result if (presumably)
1110 @void@.
1111
1112 \begin{code}
1113 disambigGroup :: [Inst] -- All standard classes of form (C a)
1114               -> TcM s TcDictBinds
1115
1116 disambigGroup dicts
1117   |   any isNumericClass classes        -- Guaranteed all standard classes
1118           -- see comment at the end of function for reasons as to
1119           -- why the defaulting mechanism doesn't apply to groups that
1120           -- include CCallable or CReturnable dicts.
1121    && not (any isCcallishClass classes)
1122   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1123         -- SO, TRY DEFAULT TYPES IN ORDER
1124
1125         -- Failure here is caused by there being no type in the
1126         -- default list which can satisfy all the ambiguous classes.
1127         -- For example, if Real a is reqd, but the only type in the
1128         -- default list is Int.
1129     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
1130     let
1131       try_default []    -- No defaults work, so fail
1132         = failTc
1133
1134       try_default (default_ty : default_tys)
1135         = tryTc_ (try_default default_tys) $    -- If default_ty fails, we try
1136                                                 -- default_tys instead
1137           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
1138           returnTc default_ty
1139         where
1140           thetas = classes `zip` repeat [default_ty]
1141     in
1142         -- See if any default works, and if so bind the type variable to it
1143         -- If not, add an AmbigErr
1144     recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds)     $
1145
1146     try_default default_tys                     `thenTc` \ chosen_default_ty ->
1147
1148         -- Bind the type variable and reduce the context, for real this time
1149     unifyTauTy chosen_default_ty (mkTyVarTy tyvar)      `thenTc_`
1150     reduceContext (text "disambig" <+> ppr dicts)
1151                   try_me [] dicts                       `thenTc` \ (binds, frees, ambigs) ->
1152     ASSERT( null frees && null ambigs )
1153     warnDefault dicts chosen_default_ty                 `thenTc_`
1154     returnTc binds
1155
1156   | all isCreturnableClass classes
1157   =     -- Default CCall stuff to (); we don't even both to check that () is an
1158         -- instance of CReturnable, because we know it is.
1159     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
1160     returnTc EmptyMonoBinds
1161
1162   | otherwise -- No defaults
1163   = complain dicts      `thenNF_Tc_`
1164     returnTc EmptyMonoBinds
1165
1166   where
1167     complain    = addAmbigErrs tyVarsOfInst
1168     try_me inst = ReduceMe AddToIrreds          -- This reduce should not fail
1169     tyvar       = get_tv (head dicts)           -- Should be non-empty
1170     classes     = map get_clas dicts
1171 \end{code}
1172
1173 [Aside - why the defaulting mechanism is turned off when
1174  dealing with arguments and results to ccalls.
1175
1176 When typechecking _ccall_s, TcExpr ensures that the external
1177 function is only passed arguments (and in the other direction,
1178 results) of a restricted set of 'native' types. This is
1179 implemented via the help of the pseudo-type classes,
1180 @CReturnable@ (CR) and @CCallable@ (CC.)
1181
1182 The interaction between the defaulting mechanism for numeric
1183 values and CC & CR can be a bit puzzling to the user at times.
1184 For example,
1185
1186     x <- _ccall_ f
1187     if (x /= 0) then
1188        _ccall_ g x
1189      else
1190        return ()
1191
1192 What type has 'x' got here? That depends on the default list
1193 in operation, if it is equal to Haskell 98's default-default
1194 of (Integer, Double), 'x' has type Double, since Integer
1195 is not an instance of CR. If the default list is equal to
1196 Haskell 1.4's default-default of (Int, Double), 'x' has type
1197 Int.
1198
1199 To try to minimise the potential for surprises here, the
1200 defaulting mechanism is turned off in the presence of
1201 CCallable and CReturnable.
1202
1203 ]
1204
1205 Errors and contexts
1206 ~~~~~~~~~~~~~~~~~~~
1207 ToDo: for these error messages, should we note the location as coming
1208 from the insts, or just whatever seems to be around in the monad just
1209 now?
1210
1211 \begin{code}
1212 genCantGenErr insts     -- Can't generalise these Insts
1213   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1214          nest 4 (pprInstsInFull insts)
1215         ]
1216
1217 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1218
1219 addAmbigErr ambig_tv_fn dict
1220   = addInstErrTcM (instLoc dict)
1221         (tidy_env,
1222          sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
1223               nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1224   where
1225     ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1226     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1227
1228 warnDefault dicts default_ty
1229   | not opt_WarnTypeDefaults
1230   = returnNF_Tc ()
1231
1232   | otherwise
1233   = warnTc True msg
1234   where
1235     msg | length dicts > 1
1236         = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1237           $$ pprInstsInFull tidy_dicts
1238         | otherwise
1239         = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1240           ptext SLIT("to type") <+> quotes (ppr default_ty)
1241
1242     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1243
1244 addTopIPErr dict
1245   = addInstErrTcM (instLoc dict)
1246         (tidy_env,
1247          ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
1248   where
1249     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1250
1251 -- Used for top-level irreducibles
1252 addTopInstanceErr dict
1253   = addInstErrTcM (instLoc dict)
1254         (tidy_env,
1255          ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1256   where
1257     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1258
1259 -- The error message when we don't find a suitable instance
1260 -- is complicated by the fact that sometimes this is because
1261 -- there is no instance, and sometimes it's because there are
1262 -- too many instances (overlap).  See the comments in TcEnv.lhs
1263 -- with the InstEnv stuff.
1264 addNoInstanceErr str givens dict
1265   = tcGetInstEnv        `thenNF_Tc` \ inst_env ->
1266     let
1267         doc = vcat [herald <+> quotes (pprInst tidy_dict),
1268                     nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
1269                     ambig_doc,
1270                     ptext SLIT("Probable fix:"),
1271                     nest 4 fix1,
1272                     nest 4 fix2]
1273
1274         herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
1275         unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
1276                     | otherwise     = empty
1277
1278         ambig_doc
1279             | not ambig_overlap = empty
1280             | otherwise
1281             = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
1282                     nest 4 (ptext SLIT("depends on the instantiation of") <+>
1283                             quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
1284
1285         fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
1286                     ptext SLIT("to the") <+> str]
1287
1288         fix2 | isTyVarDict dict || ambig_overlap
1289              = empty
1290              | otherwise
1291              = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
1292
1293         (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1294
1295             -- Checks for the ambiguous case when we have overlapping instances
1296         ambig_overlap | isClassDict dict
1297                       = case lookupInstEnv inst_env clas tys of
1298                             NoMatch ambig -> ambig
1299                             other         -> False
1300                       | otherwise = False
1301                       where
1302                         (clas,tys) = getDictClassTys dict
1303     in
1304     addInstErrTcM (instLoc dict) (tidy_env, doc)
1305
1306 -- Used for the ...Thetas variants; all top level
1307 addNoInstErr (c,ts)
1308   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1309
1310 reduceDepthErr n stack
1311   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1312           ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1313           nest 4 (pprInstsInFull stack)]
1314
1315 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
1316 \end{code}