ghc/compiler/typecheck/TcSimplify.lhs

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