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 HsSyn            ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 127 import TcHsSyn          ( TcExpr, TcId,
 128                           TcMonoBinds, TcDictBinds
 129                         )
 130
 131 import TcMonad
 132 import Inst             ( lookupInst, lookupSimpleInst, LookupInstResult(..),
 133                           tyVarsOfInst,
 134                           isDict, isClassDict, isMethod, notFunDep,
 135                           isStdClassTyVarDict, isMethodFor,
 136                           instToId, instBindingRequired, instCanBeGeneralised,
 137                           newDictFromOld, newFunDepFromDict,
 138                           getDictClassTys, getIPs, isTyVarDict,
 139                           getDictPred_maybe, getMethodTheta_maybe,
 140                           instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
 141                           Inst, LIE, pprInsts, pprInstsInFull,
 142                           mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
 143                           lieToList
 144                         )
 145 import TcEnv            ( tcGetGlobalTyVars, tcGetInstEnv )
 146 import InstEnv          ( lookupInstEnv, InstLookupResult(..) )
 147
 148 import TcType           ( TcTyVarSet )
 149 import TcUnify          ( unifyTauTy )
 150 import Id               ( idType )
 151 import Class            ( Class, classBigSig )
 152 import PrelInfo         ( isNumericClass, isCreturnableClass, isCcallishClass )
 153
 154 import Type             ( Type, ClassContext,
 155                           mkTyVarTy, getTyVar,
 156                           isTyVarTy, splitSigmaTy, tyVarsOfTypes
 157                         )
 158 import Subst            ( mkTopTyVarSubst, substClasses )
 159 import PprType          ( pprConstraint )
 160 import TysWiredIn       ( unitTy )
 161 import VarSet
 162 import FiniteMap
 163 import Outputable
 164 import ListSetOps       ( equivClasses )
 165 import Util             ( zipEqual, mapAccumL )
 166 import List             ( partition )
 167 import Maybe            ( fromJust )
 168 import Maybes           ( maybeToBool )
 169 import CmdLineOpts
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection[tcSimplify-main]{Main entry function}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 180 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 181 top level defns we *do* squash constants, so that they stay local to a
 182 single defn.  This makes things which are inlined more likely to be
 183 exportable, because their constants are "inside".  Later passes will
 184 float them out if poss, after inlinings are sorted out.
 185
 186 \begin{code}
 187 tcSimplify
 188         :: SDoc
 189         -> TcTyVarSet                   -- ``Local''  type variables
 190                                         -- ASSERT: this tyvar set is already zonked
 191         -> LIE                          -- Wanted
 192         -> TcM (LIE,                    -- Free
 193                   TcDictBinds,          -- Bindings
 194                   LIE)                  -- Remaining wanteds; no dups
 195
 196 tcSimplify str local_tvs wanted_lie
 197 {- this is just an optimization, and interferes with implicit params,
 198    disable it for now.  same goes for tcSimplifyAndCheck
 199   | isEmptyVarSet local_tvs
 200   = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
 201
 202   | otherwise
 203 -}
 204   = reduceContext str try_me [] wanteds         `thenTc` \ (binds, frees, irreds) ->
 205
 206         -- Check for non-generalisable insts
 207     let
 208         cant_generalise = filter (not . instCanBeGeneralised) irreds
 209     in
 210     checkTc (null cant_generalise)
 211             (genCantGenErr cant_generalise)     `thenTc_`
 212
 213         -- Check for ambiguous insts.
 214         -- You might think these can't happen (I did) because an ambiguous
 215         -- inst like (Eq a) will get tossed out with "frees", and eventually
 216         -- dealt with by tcSimplifyTop.
 217         -- But we can get stuck with
 218         --      C a b
 219         -- where "a" is one of the local_tvs, but "b" is unconstrained.
 220         -- Then we must yell about the ambiguous b
 221         -- But we must only do so if "b" really is unconstrained; so
 222         -- we must grab the global tyvars to answer that question
 223     tcGetGlobalTyVars                           `thenNF_Tc` \ global_tvs ->
 224     let
 225         avail_tvs           = local_tvs `unionVarSet` global_tvs
 226         (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
 227         ambig_tv_fn dict    = tyVarsOfInst dict `minusVarSet` avail_tvs
 228     in
 229     addAmbigErrs ambig_tv_fn bad_guys   `thenNF_Tc_`
 230
 231
 232         -- Finished
 233     returnTc (mkLIE frees, binds, mkLIE irreds')
 234   where
 235     wanteds = lieToList wanted_lie
 236
 237     try_me inst
 238       -- Does not constrain a local tyvar
 239       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 240         && null (getIPs inst)
 241       = -- if is_top_level then
 242         --   FreeIfTautological           -- Special case for inference on
 243         --                                -- top-level defns
 244         -- else
 245         Free
 246
 247       -- We're infering (not checking) the type, and
 248       -- the inst constrains a local type variable
 249       | isClassDict inst = DontReduceUnlessConstant     -- Dicts
 250       | otherwise        = ReduceMe AddToIrreds         -- Lits and Methods
 251 \end{code}
 252
 253 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 254 that there is an empty wanted-set at the end.  It may still return
 255 some of constant insts, which have to be resolved finally at the end.
 256
 257 \begin{code}
 258 tcSimplifyAndCheck
 259          :: SDoc
 260          -> TcTyVarSet          -- ``Local''  type variables
 261                                 -- ASSERT: this tyvar set is already zonked
 262          -> LIE                 -- Given; constrain only local tyvars
 263          -> LIE                 -- Wanted
 264          -> TcM (LIE,           -- Free
 265                    TcDictBinds) -- Bindings
 266
 267 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
 268 {-
 269   | isEmptyVarSet local_tvs
 270         -- This can happen quite legitimately; for example in
 271         --      instance Num Int where ...
 272   = returnTc (wanted_lie, EmptyMonoBinds)
 273
 274   | otherwise
 275 -}
 276   = reduceContext str try_me givens wanteds     `thenTc` \ (binds, frees, irreds) ->
 277
 278         -- Complain about any irreducible ones
 279     mapNF_Tc complain irreds    `thenNF_Tc_`
 280
 281         -- Done
 282     returnTc (mkLIE frees, binds)
 283   where
 284     givens  = lieToList given_lie
 285     wanteds = lieToList wanted_lie
 286     given_dicts = filter isClassDict givens
 287
 288     try_me inst
 289       -- Does not constrain a local tyvar
 290       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 291         && (not (isMethod inst) || null (getIPs inst))
 292       = Free
 293
 294       -- When checking against a given signature we always reduce
 295       -- until we find a match against something given, or can't reduce
 296       | otherwise
 297       = ReduceMe AddToIrreds
 298
 299     complain dict = mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 300                     addNoInstanceErr str given_dicts dict
 301 \end{code}
 302
 303 On the LHS of transformation rules we only simplify methods and constants,
 304 getting dictionaries.  We want to keep all of them unsimplified, to serve
 305 as the available stuff for the RHS of the rule.
 306
 307 The same thing is used for specialise pragmas. Consider
 308
 309         f :: Num a => a -> a
 310         {-# SPECIALISE f :: Int -> Int #-}
 311         f = ...
 312
 313 The type checker generates a binding like:
 314
 315         f_spec = (f :: Int -> Int)
 316
 317 and we want to end up with
 318
 319         f_spec = _inline_me_ (f Int dNumInt)
 320
 321 But that means that we must simplify the Method for f to (f Int dNumInt)!
 322 So tcSimplifyToDicts squeezes out all Methods.
 323
 324 \begin{code}
 325 tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds)
 326 tcSimplifyToDicts wanted_lie
 327   = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds  `thenTc` \ (binds, frees, irreds) ->
 328     ASSERT( null frees )
 329     returnTc (mkLIE irreds, binds)
 330   where
 331     wanteds = lieToList wanted_lie
 332
 333         -- Reduce methods and lits only; stop as soon as we get a dictionary
 334     try_me inst | isDict inst = DontReduce
 335                 | otherwise   = ReduceMe AddToIrreds
 336 \end{code}
 337
 338 The following function partitions a LIE by a predicate defined
 339 over `Pred'icates (an unfortunate overloading of terminology!).
 340 This means it sometimes has to split up `Methods', in which case
 341 a binding is generated.
 342
 343 It is used in `with' bindings to extract from the LIE the implicit
 344 parameters being bound.
 345
 346 \begin{code}
 347 partitionPredsOfLIE pred lie
 348   = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
 349   where insts = lieToList lie
 350
 351 -- warning: the term `pred' is overloaded here!
 352 partPreds pred (lie1, lie2, binds) inst
 353   | maybeToBool maybe_pred
 354   = if pred p then
 355         returnTc (consLIE inst lie1, lie2, binds)
 356     else
 357         returnTc (lie1, consLIE inst lie2, binds)
 358     where maybe_pred = getDictPred_maybe inst
 359           Just p = maybe_pred
 360
 361 -- the assumption is that those satisfying `pred' are being extracted,
 362 -- so we leave the method untouched when nothing satisfies `pred'
 363 partPreds pred (lie1, lie2, binds1) inst
 364   | maybeToBool maybe_theta
 365   = if any pred theta then
 366         zonkInst inst                           `thenTc` \ inst' ->
 367         tcSimplifyToDicts (unitLIE inst')       `thenTc` \ (lie3, binds2) ->
 368         partitionPredsOfLIE pred lie3           `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
 369         returnTc (lie1 `plusLIE` lie1',
 370                   lie2 `plusLIE` lie2',
 371                   binds1 `AndMonoBinds` binds2)
 372     else
 373         returnTc (lie1, consLIE inst lie2, binds1)
 374     where maybe_theta = getMethodTheta_maybe inst
 375           Just theta = maybe_theta
 376
 377 partPreds pred (lie1, lie2, binds) inst
 378   = returnTc (lie1, consLIE inst lie2, binds)
 379 \end{code}
 380
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection{Data types for the reduction mechanism}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 The main control over context reduction is here
 389
 390 \begin{code}
 391 data WhatToDo
 392  = ReduceMe               -- Try to reduce this
 393         NoInstanceAction  -- What to do if there's no such instance
 394
 395  | DontReduce                   -- Return as irreducible
 396
 397  | DontReduceUnlessConstant     -- Return as irreducible unless it can
 398                                 -- be reduced to a constant in one step
 399
 400  | Free                   -- Return as free
 401
 402  | FreeIfTautological     -- Return as free iff it's tautological;
 403                           -- if not, return as irreducible
 404         -- The FreeIfTautological case is to allow the possibility
 405         -- of generating functions with types like
 406         --      f :: C Int => Int -> Int
 407         -- Here, the C Int isn't a tautology presumably because Int
 408         -- isn't an instance of C in this module; but perhaps it will
 409         -- be at f's call site(s).  Haskell doesn't allow this at
 410         -- present.
 411
 412 data NoInstanceAction
 413   = Stop                -- Fail; no error message
 414                         -- (Only used when tautology checking.)
 415
 416   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 417                         -- produce an error message of any kind.
 418                         -- It might be quite legitimate such as (Eq a)!
 419 \end{code}
 420
 421
 422
 423 \begin{code}
 424 type RedState s
 425   = (Avails s,          -- What's available
 426      [Inst],            -- Insts for which try_me returned Free
 427      [Inst]             -- Insts for which try_me returned DontReduce
 428     )
 429
 430 type Avails s = FiniteMap Inst Avail
 431
 432 data Avail
 433   = Avail
 434         TcId            -- The "main Id"; that is, the Id for the Inst that
 435                         -- caused this avail to be put into the finite map in the first place
 436                         -- It is this Id that is bound to the RHS.
 437
 438         RHS             -- The RHS: an expression whose value is that Inst.
 439                         -- The main Id should be bound to this RHS
 440
 441         [TcId]  -- Extra Ids that must all be bound to the main Id.
 442                         -- At the end we generate a list of bindings
 443                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 444
 445 data RHS
 446   = NoRhs               -- Used for irreducible dictionaries,
 447                         -- which are going to be lambda bound, or for those that are
 448                         -- suppplied as "given" when checking againgst a signature.
 449                         --
 450                         -- NoRhs is also used for Insts like (CCallable f)
 451                         -- where no witness is required.
 452
 453   | Rhs                 -- Used when there is a RHS
 454         TcExpr
 455         Bool            -- True => the RHS simply selects a superclass dictionary
 456                         --         from a subclass dictionary.
 457                         -- False => not so.
 458                         -- This is useful info, because superclass selection
 459                         -- is cheaper than building the dictionary using its dfun,
 460                         -- and we can sometimes replace the latter with the former
 461
 462   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 463                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 464                         -- the finite map, with an PassiveScSel.  Then if the
 465                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 466         TcExpr
 467         [Inst]  -- List of Insts that are free in the RHS.
 468                         -- If the main Id is subsequently needed, we toss this list into
 469                         -- the needed-inst pool so that we make sure their bindings
 470                         -- will actually be produced.
 471                         --
 472                         -- Invariant: these Insts are already in the finite mapping
 473
 474
 475 pprAvails avails = vcat (map pprAvail (eltsFM avails))
 476
 477 pprAvail (Avail main_id rhs ids)
 478   = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 479
 480 instance Outputable Avail where
 481     ppr = pprAvail
 482
 483 pprRhs NoRhs = text "<no rhs>"
 484 pprRhs (Rhs rhs b) = ppr rhs
 485 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 486 \end{code}
 487
 488
 489 %************************************************************************
 490 %*                                                                      *
 491 \subsection[reduce]{@reduce@}
 492 %*                                                                      *
 493 %************************************************************************
 494
 495 The main entry point for context reduction is @reduceContext@:
 496
 497 \begin{code}
 498 reduceContext :: SDoc -> (Inst -> WhatToDo)
 499               -> [Inst] -- Given
 500               -> [Inst] -- Wanted
 501               -> TcM (TcDictBinds,
 502                         [Inst],         -- Free
 503                         [Inst])         -- Irreducible
 504
 505 reduceContext str try_me givens wanteds
 506   =     -- Zonking first
 507     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 508     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 509     -- JRL - process fundeps last.  We eliminate fundeps by seeing
 510     -- what available classes generate them, so we need to process the
 511     -- classes first. (would it be useful to make LIEs ordered in the first place?)
 512     let (wantedOther, wantedFds) = partition notFunDep wanteds
 513         wanteds'                 = wantedOther ++ wantedFds in
 514
 515 {-
 516     pprTrace "reduceContext" (vcat [
 517              text "----------------------",
 518              str,
 519              text "given" <+> ppr givens,
 520              text "wanted" <+> ppr wanteds,
 521              text "----------------------"
 522              ]) $
 523 -}
 524         -- Build the Avail mapping from "givens"
 525     foldlNF_Tc addGiven emptyFM givens                  `thenNF_Tc` \ avails ->
 526
 527         -- Do the real work
 528     reduceList (0,[]) try_me wanteds' (avails, [], [])  `thenNF_Tc` \ (avails, frees, irreds) ->
 529
 530         -- Extract the bindings from avails
 531     let
 532        binds = foldFM add_bind EmptyMonoBinds avails
 533
 534        add_bind _ (Avail main_id rhs ids) binds
 535          = foldr add_synonym (add_rhs_bind rhs binds) ids
 536          where
 537            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 538            add_rhs_bind other       binds = binds
 539
 540            -- Add the trivial {x = y} bindings
 541            -- The main Id can end up in the list when it's first added passively
 542            -- and then activated, so we have to filter it out.  A bit of a hack.
 543            add_synonym id binds
 544              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 545              | otherwise     = binds
 546     in
 547 {-
 548     pprTrace ("reduceContext end") (vcat [
 549              text "----------------------",
 550              str,
 551              text "given" <+> ppr givens,
 552              text "wanted" <+> ppr wanteds,
 553              text "----",
 554              text "avails" <+> pprAvails avails,
 555              text "frees" <+> ppr frees,
 556              text "irreds" <+> ppr irreds,
 557              text "----------------------"
 558              ]) $
 559 -}
 560     returnNF_Tc (binds, frees, irreds)
 561 \end{code}
 562
 563 The main context-reduction function is @reduce@.  Here's its game plan.
 564
 565 \begin{code}
 566 reduceList :: (Int,[Inst])              -- Stack (for err msgs)
 567                                         -- along with its depth
 568            -> (Inst -> WhatToDo)
 569            -> [Inst]
 570            -> RedState s
 571            -> TcM (RedState s)
 572 \end{code}
 573
 574 @reduce@ is passed
 575      try_me:    given an inst, this function returns
 576                   Reduce       reduce this
 577                   DontReduce   return this in "irreds"
 578                   Free         return this in "frees"
 579
 580      wanteds:   The list of insts to reduce
 581      state:     An accumulating parameter of type RedState
 582                 that contains the state of the algorithm
 583
 584   It returns a RedState.
 585
 586 The (n,stack) pair is just used for error reporting.
 587 n is always the depth of the stack.
 588 The stack is the stack of Insts being reduced: to produce X
 589 I had to produce Y, to produce Y I had to produce Z, and so on.
 590
 591 \begin{code}
 592 reduceList (n,stack) try_me wanteds state
 593   | n > opt_MaxContextReductionDepth
 594   = failWithTc (reduceDepthErr n stack)
 595
 596   | otherwise
 597   =
 598 #ifdef DEBUG
 599    (if n > 8 then
 600         pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
 601     else (\x->x))
 602 #endif
 603     go wanteds state
 604   where
 605     go []     state = returnTc state
 606     go (w:ws) state = reduce (n+1, w:stack) try_me w state      `thenTc` \ state' ->
 607                       go ws state'
 608
 609     -- Base case: we're done!
 610 reduce stack try_me wanted state@(avails, frees, irreds)
 611     -- It's the same as an existing inst, or a superclass thereof
 612   | wanted `elemFM` avails
 613   = returnTc (activate avails wanted, frees, irreds)
 614
 615   | otherwise
 616   = case try_me wanted of {
 617
 618     ReduceMe no_instance_action ->      -- It should be reduced
 619         lookupInst wanted             `thenNF_Tc` \ lookup_result ->
 620         case lookup_result of
 621             GenInst wanteds' rhs -> use_instance wanteds' rhs
 622             SimpleInst rhs       -> use_instance []       rhs
 623
 624             NoInstance ->    -- No such instance!
 625                     case no_instance_action of
 626                         Stop        -> failTc
 627                         AddToIrreds -> add_to_irreds
 628     ;
 629     Free ->     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 630                 -- First, see if the inst can be reduced to a constant in one step
 631         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 632         case lookup_result of
 633             SimpleInst rhs -> use_instance [] rhs
 634             other          -> add_to_frees
 635
 636
 637
 638     ;
 639     FreeIfTautological -> -- It's free and this is a top level binding, so
 640                           -- check whether it's a tautology or not
 641         tryTc_
 642           add_to_irreds   -- If tautology trial fails, add to irreds
 643
 644           -- If tautology succeeds, just add to frees
 645           (reduce stack try_me_taut wanted (avails, [], [])     `thenTc_`
 646            returnTc (avails, wanted:frees, irreds))
 647
 648
 649     ;
 650
 651     DontReduce -> add_to_irreds
 652     ;
 653
 654     DontReduceUnlessConstant ->    -- It's irreducible (or at least should not be reduced)
 655         -- See if the inst can be reduced to a constant in one step
 656         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 657         case lookup_result of
 658            SimpleInst rhs -> use_instance [] rhs
 659            other          -> add_to_irreds
 660     }
 661   where
 662         -- The three main actions
 663     add_to_frees  = let
 664                         avails' = addFree avails wanted
 665                         -- Add the thing to the avails set so any identical Insts
 666                         -- will be commoned up with it right here
 667                     in
 668                     returnTc (avails', wanted:frees, irreds)
 669
 670     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 671                     returnTc (avails',  frees, wanted:irreds)
 672
 673     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 674                                 reduceList stack try_me wanteds' (avails', frees, irreds)
 675
 676
 677     -- The try-me to use when trying to identify tautologies
 678     -- It blunders on reducing as much as possible
 679     try_me_taut inst = ReduceMe Stop    -- No error recovery
 680 \end{code}
 681
 682
 683 \begin{code}
 684 activate :: Avails s -> Inst -> Avails s
 685          -- Activate the binding for Inst, ensuring that a binding for the
 686          -- wanted Inst will be generated.
 687          -- (Activate its parent if necessary, recursively).
 688          -- Precondition: the Inst is in Avails already
 689
 690 activate avails wanted
 691   | not (instBindingRequired wanted)
 692   = avails
 693
 694   | otherwise
 695   = case lookupFM avails wanted of
 696
 697       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 698                foldl activate avails' insts      -- Activate anything it needs
 699              where
 700                avails' = addToFM avails wanted avail'
 701                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 702
 703       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 704                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 705
 706       Nothing -> panic "activate"
 707   where
 708       wanted_id = instToId wanted
 709
 710 addWanted avails wanted rhs_expr
 711   = ASSERT( not (wanted `elemFM` avails) )
 712     addFunDeps (addToFM avails wanted avail) wanted
 713         -- NB: we don't add the thing's superclasses too!
 714         -- Why not?  Because addWanted is used when we've successfully used an
 715         -- instance decl to reduce something; e.g.
 716         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 717         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 718         -- If we put the superclasses of "d" in avails, then we might end up
 719         -- expressing "d1" in terms of "d", which would be a disaster.
 720   where
 721     avail = Avail (instToId wanted) rhs []
 722
 723     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 724         | otherwise                  = NoRhs
 725
 726 addFree :: Avails s -> Inst -> (Avails s)
 727         -- When an Inst is tossed upstairs as 'free' we nevertheless add it
 728         -- to avails, so that any other equal Insts will be commoned up right
 729         -- here rather than also being tossed upstairs.  This is really just
 730         -- an optimisation, and perhaps it is more trouble that it is worth,
 731         -- as the following comments show!
 732         --
 733         -- NB1: do *not* add superclasses.  If we have
 734         --      df::Floating a
 735         --      dn::Num a
 736         -- but a is not bound here, then we *don't* want to derive
 737         -- dn from df here lest we lose sharing.
 738         --
 739         -- NB2: do *not* add the Inst to avails at all if it's a method.
 740         -- The following situation shows why this is bad:
 741         --      truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
 742         -- From an application (truncate f i) we get
 743         --      t1 = truncate at f
 744         --      t2 = t1 at i
 745         -- If we have also have a secon occurrence of truncate, we get
 746         --      t3 = truncate at f
 747         --      t4 = t3 at i
 748         -- When simplifying with i,f free, we might still notice that
 749         --   t1=t3; but alas, the binding for t2 (which mentions t1)
 750         --   will continue to float out!
 751         -- Solution: never put methods in avail till they are captured
 752         -- in which case addFree isn't used
 753 addFree avails free
 754   | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
 755   | otherwise   = avails
 756
 757 addGiven :: Avails s -> Inst -> NF_TcM (Avails s)
 758 addGiven avails given
 759   =      -- ASSERT( not (given `elemFM` avails) )
 760          -- This assertion isn't necessarily true.  It's permitted
 761          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 762          -- and when typechecking instance decls we generate redundant "givens" too.
 763     -- addAvail avails given avail
 764     addAvail avails given avail `thenNF_Tc` \av ->
 765     zonkInst given `thenNF_Tc` \given' ->
 766     returnNF_Tc av
 767   where
 768     avail = Avail (instToId given) NoRhs []
 769
 770 addAvail avails wanted avail
 771   = addSuperClasses (addToFM avails wanted avail) wanted
 772
 773 addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s)
 774                 -- Add all the superclasses of the Inst to Avails
 775                 -- Invariant: the Inst is already in Avails.
 776
 777 addSuperClasses avails dict
 778   | not (isClassDict dict)
 779   = returnNF_Tc avails
 780
 781   | otherwise   -- It is a dictionary
 782   = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
 783     addFunDeps avails' dict
 784   where
 785     (clas, tys) = getDictClassTys dict
 786     (tyvars, sc_theta, sc_sels, _) = classBigSig clas
 787     sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
 788
 789     add_sc avails ((super_clas, super_tys), sc_sel)
 790       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 791         let
 792            sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
 793                                 [instToId dict]
 794         in
 795         case lookupFM avails super_dict of
 796
 797              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 798                   -- Already there, but not as a superclass selector
 799                   -- No need to look at its superclasses; since it's there
 800                   --    already they must be already in avails
 801                   -- However, we must remember to activate the dictionary
 802                   -- from which it is (now) generated
 803                   returnNF_Tc (activate avails' dict)
 804                 where
 805                   avails' = addToFM avails super_dict avail
 806                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 807
 808              Just (Avail _ _ _) -> returnNF_Tc avails
 809                   -- Already there; no need to do anything
 810
 811              Nothing ->
 812                   -- Not there at all, so add it, and its superclasses
 813                   addAvail avails super_dict avail
 814                 where
 815                   avail   = Avail (instToId super_dict)
 816                                   (PassiveScSel sc_sel_rhs [dict])
 817                                   []
 818
 819 addFunDeps :: Avails s -> Inst -> NF_TcM (Avails s)
 820            -- Add in the functional dependencies generated by the inst
 821 addFunDeps avails inst
 822   = newFunDepFromDict inst      `thenNF_Tc` \ fdInst_maybe ->
 823     case fdInst_maybe of
 824       Nothing -> returnNF_Tc avails
 825       Just fdInst ->
 826         let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
 827         addAvail avails fdInst fdAvail
 828 \end{code}
 829
 830 %************************************************************************
 831 %*                                                                      *
 832 \subsection[simple]{@Simple@ versions}
 833 %*                                                                      *
 834 %************************************************************************
 835
 836 Much simpler versions when there are no bindings to make!
 837
 838 @tcSimplifyThetas@ simplifies class-type constraints formed by
 839 @deriving@ declarations and when specialising instances.  We are
 840 only interested in the simplified bunch of class/type constraints.
 841
 842 It simplifies to constraints of the form (C a b c) where
 843 a,b,c are type variables.  This is required for the context of
 844 instance declarations.
 845
 846 \begin{code}
 847 tcSimplifyThetas :: ClassContext                -- Wanted
 848                  -> TcM ClassContext            -- Needed
 849
 850 tcSimplifyThetas wanteds
 851   = doptsTc Opt_GlasgowExts             `thenNF_Tc` \ glaExts ->
 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 | glaExts   = [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 ()
 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 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 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 (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 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         -- Disambiguate the ones that look feasible
1077     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
1078
1079         -- And complain about the ones that don't
1080     mapNF_Tc complain bad_guys          `thenNF_Tc_`
1081
1082     returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1083   where
1084     wanteds     = lieToList wanted_lie
1085     try_me inst = ReduceMe AddToIrreds
1086
1087     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1088
1089     complain d | not (null (getIPs d))          = addTopIPErr d
1090                | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1091                | otherwise                      = addAmbigErr tyVarsOfInst d
1092
1093 get_tv d   = case getDictClassTys d of
1094                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1095 get_clas d = case getDictClassTys d of
1096                    (clas, [ty]) -> clas
1097 \end{code}
1098
1099 @disambigOne@ assumes that its arguments dictionaries constrain all
1100 the same type variable.
1101
1102 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1103 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
1104 the most common use of defaulting is code like:
1105 \begin{verbatim}
1106         _ccall_ foo     `seqPrimIO` bar
1107 \end{verbatim}
1108 Since we're not using the result of @foo@, the result if (presumably)
1109 @void@.
1110
1111 \begin{code}
1112 disambigGroup :: [Inst] -- All standard classes of form (C a)
1113               -> TcM TcDictBinds
1114
1115 disambigGroup dicts
1116   |   any isNumericClass classes        -- Guaranteed all standard classes
1117           -- see comment at the end of function for reasons as to
1118           -- why the defaulting mechanism doesn't apply to groups that
1119           -- include CCallable or CReturnable dicts.
1120    && not (any isCcallishClass classes)
1121   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1122         -- SO, TRY DEFAULT TYPES IN ORDER
1123
1124         -- Failure here is caused by there being no type in the
1125         -- default list which can satisfy all the ambiguous classes.
1126         -- For example, if Real a is reqd, but the only type in the
1127         -- default list is Int.
1128     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
1129     let
1130       try_default []    -- No defaults work, so fail
1131         = failTc
1132
1133       try_default (default_ty : default_tys)
1134         = tryTc_ (try_default default_tys) $    -- If default_ty fails, we try
1135                                                 -- default_tys instead
1136           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
1137           returnTc default_ty
1138         where
1139           thetas = classes `zip` repeat [default_ty]
1140     in
1141         -- See if any default works, and if so bind the type variable to it
1142         -- If not, add an AmbigErr
1143     recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds)     $
1144
1145     try_default default_tys                     `thenTc` \ chosen_default_ty ->
1146
1147         -- Bind the type variable and reduce the context, for real this time
1148     unifyTauTy chosen_default_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   = doptsTc Opt_WarnTypeDefaults  `thenTc` \ warn_flag ->
1229     if warn_flag
1230         then mapNF_Tc warn groups  `thenNF_Tc_`  returnNF_Tc ()
1231         else returnNF_Tc ()
1232
1233   where
1234         -- Tidy them first
1235     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1236
1237         -- Group the dictionaries by source location
1238     groups      = equivClasses cmp tidy_dicts
1239     i1 `cmp` i2 = get_loc i1 `compare` get_loc i2
1240     get_loc i   = case instLoc i of { (_,loc,_) -> loc }
1241
1242     warn [dict] = tcAddSrcLoc (get_loc dict) $
1243                   warnTc True (ptext SLIT("Defaulting") <+> quotes (pprInst dict) <+>
1244                                ptext SLIT("to type") <+> quotes (ppr default_ty))
1245
1246     warn dicts  = tcAddSrcLoc (get_loc (head dicts)) $
1247                   warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty),
1248                                      pprInstsInFull dicts])
1249
1250 addTopIPErr dict
1251   = addInstErrTcM (instLoc dict)
1252         (tidy_env,
1253          ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
1254   where
1255     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1256
1257 -- Used for top-level irreducibles
1258 addTopInstanceErr dict
1259   = addInstErrTcM (instLoc dict)
1260         (tidy_env,
1261          ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1262   where
1263     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1264
1265 -- The error message when we don't find a suitable instance
1266 -- is complicated by the fact that sometimes this is because
1267 -- there is no instance, and sometimes it's because there are
1268 -- too many instances (overlap).  See the comments in TcEnv.lhs
1269 -- with the InstEnv stuff.
1270 addNoInstanceErr str givens dict
1271   = tcGetInstEnv        `thenNF_Tc` \ inst_env ->
1272     let
1273         doc = vcat [sep [herald <+> quotes (pprInst tidy_dict),
1274                          nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
1275                     ambig_doc,
1276                     ptext SLIT("Probable fix:"),
1277                     nest 4 fix1,
1278                     nest 4 fix2]
1279
1280         herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
1281         unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
1282                     | otherwise     = empty
1283
1284         ambig_doc
1285             | not ambig_overlap = empty
1286             | otherwise
1287             = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
1288                     nest 4 (ptext SLIT("depends on the instantiation of") <+>
1289                             quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
1290
1291         fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
1292                     ptext SLIT("to the") <+> str]
1293
1294         fix2 | isTyVarDict dict || ambig_overlap
1295              = empty
1296              | otherwise
1297              = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
1298
1299         (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1300
1301             -- Checks for the ambiguous case when we have overlapping instances
1302         ambig_overlap | isClassDict dict
1303                       = case lookupInstEnv inst_env clas tys of
1304                             NoMatch ambig -> ambig
1305                             other         -> False
1306                       | otherwise = False
1307                       where
1308                         (clas,tys) = getDictClassTys dict
1309     in
1310     addInstErrTcM (instLoc dict) (tidy_env, doc)
1311
1312 -- Used for the ...Thetas variants; all top level
1313 addNoInstErr (c,ts)
1314   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1315
1316 reduceDepthErr n stack
1317   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1318           ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1319           nest 4 (pprInstsInFull stack)]
1320
1321 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
1322 \end{code}