ghc/compiler/typecheck/TcSimplify.lhs

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