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,
 120         tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
 121         bindInstsOfLocalFuns
 122     ) where
 123
 124 #include "HsVersions.h"
 125
 126 import CmdLineOpts      ( opt_MaxContextReductionDepth )
 127 import HsSyn            ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 128 import TcHsSyn          ( TcExpr, TcIdOcc(..), TcIdBndr,
 129                           TcMonoBinds, TcDictBinds
 130                         )
 131
 132 import TcMonad
 133 import Inst             ( lookupInst, lookupSimpleInst, LookupInstResult(..),
 134                           tyVarsOfInst,
 135                           isDict, isStdClassTyVarDict, isMethodFor,
 136                           instToId, instBindingRequired, instCanBeGeneralised,
 137                           newDictFromOld,
 138                           instLoc, getDictClassTys,
 139                           pprInst, zonkInst, tidyInst, tidyInsts,
 140                           Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
 141                           plusLIE, pprOrigin
 142                         )
 143 import TcEnv            ( TcIdOcc(..), tcGetGlobalTyVars )
 144 import TcType           ( TcType, TcTyVarSet, typeToTcType )
 145 import TcUnify          ( unifyTauTy )
 146 import Id               ( idType )
 147 import VarSet           ( mkVarSet )
 148
 149 import Bag              ( bagToList )
 150 import Class            ( Class, ClassInstEnv, classBigSig, classInstEnv )
 151 import PrelInfo         ( isNumericClass, isCreturnableClass )
 152
 153 import Type             ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
 154                           isTyVarTy, substFlexiTheta, splitSigmaTy,
 155                           tyVarsOfTypes
 156                         )
 157 import PprType          ( pprConstraint )
 158 import TysWiredIn       ( unitTy )
 159 import VarSet
 160 import VarEnv           ( zipVarEnv )
 161 import FiniteMap
 162 import BasicTypes       ( TopLevelFlag(..) )
 163 import CmdLineOpts      ( opt_GlasgowExts )
 164 import Outputable
 165 import Util
 166 import List             ( partition )
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection[tcSimplify-main]{Main entry function}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 177 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 178 top level defns we *do* squash constants, so that they stay local to a
 179 single defn.  This makes things which are inlined more likely to be
 180 exportable, because their constants are "inside".  Later passes will
 181 float them out if poss, after inlinings are sorted out.
 182
 183 \begin{code}
 184 tcSimplify
 185         :: SDoc
 186         -> TopLevelFlag
 187         -> TcTyVarSet s                 -- ``Local''  type variables
 188                                         -- ASSERT: this tyvar set is already zonked
 189         -> LIE s                        -- Wanted
 190         -> TcM s (LIE s,                        -- Free
 191                   TcDictBinds s,                -- Bindings
 192                   LIE s)                        -- Remaining wanteds; no dups
 193
 194 tcSimplify str top_lvl local_tvs wanted_lie
 195   | isEmptyVarSet local_tvs
 196   = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
 197
 198   | otherwise
 199   = reduceContext str try_me [] wanteds         `thenTc` \ (binds, frees, irreds) ->
 200
 201         -- Check for non-generalisable insts
 202     let
 203         cant_generalise = filter (not . instCanBeGeneralised) irreds
 204     in
 205     checkTc (null cant_generalise)
 206             (genCantGenErr cant_generalise)     `thenTc_`
 207
 208         -- Check for ambiguous insts.
 209         -- You might think these can't happen (I did) because an ambiguous
 210         -- inst like (Eq a) will get tossed out with "frees", and eventually
 211         -- dealt with by tcSimplifyTop.
 212         -- But we can get stuck with
 213         --      C a b
 214         -- where "a" is one of the local_tvs, but "b" is unconstrained.
 215         -- Then we must yell about the ambiguous b
 216         -- But we must only do so if "b" really is unconstrained; so
 217         -- we must grab the global tyvars to answer that question
 218     tcGetGlobalTyVars                           `thenNF_Tc` \ global_tvs ->
 219     let
 220         avail_tvs           = local_tvs `unionVarSet` global_tvs
 221         (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
 222         ambig_tv_fn dict    = tyVarsOfInst dict `minusVarSet` avail_tvs
 223     in
 224     addAmbigErrs ambig_tv_fn bad_guys   `thenNF_Tc_`
 225
 226
 227         -- Finished
 228     returnTc (mkLIE frees, binds, mkLIE irreds')
 229   where
 230     wanteds = bagToList wanted_lie
 231
 232     try_me inst
 233       -- Does not constrain a local tyvar
 234       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 235       = -- if is_top_level then
 236         --   FreeIfTautological           -- Special case for inference on
 237         --                                -- top-level defns
 238         -- else
 239         Free
 240
 241       -- We're infering (not checking) the type, and
 242       -- the inst constrains a local type variable
 243       | isDict inst  = DontReduce               -- Dicts
 244       | otherwise    = ReduceMe AddToIrreds     -- Lits and Methods
 245 \end{code}
 246
 247 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 248 that there is an empty wanted-set at the end.  It may still return
 249 some of constant insts, which have to be resolved finally at the end.
 250
 251 \begin{code}
 252 tcSimplifyAndCheck
 253          :: SDoc
 254          -> TcTyVarSet s                -- ``Local''  type variables
 255                                         -- ASSERT: this tyvar set is already zonked
 256          -> LIE s                       -- Given; constrain only local tyvars
 257          -> LIE s                       -- Wanted
 258          -> TcM s (LIE s,               -- Free
 259                    TcDictBinds s)       -- Bindings
 260
 261 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
 262   | isEmptyVarSet local_tvs
 263         -- This can happen quite legitimately; for example in
 264         --      instance Num Int where ...
 265   = returnTc (wanted_lie, EmptyMonoBinds)
 266
 267   | otherwise
 268   = reduceContext str try_me givens wanteds     `thenTc` \ (binds, frees, irreds) ->
 269
 270         -- Complain about any irreducible ones
 271     mapNF_Tc complain irreds    `thenNF_Tc_`
 272
 273         -- Done
 274     returnTc (mkLIE frees, binds)
 275   where
 276     givens  = bagToList given_lie
 277     wanteds = bagToList wanted_lie
 278
 279     try_me inst
 280       -- Does not constrain a local tyvar
 281       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 282       = Free
 283
 284       -- When checking against a given signature we always reduce
 285       -- until we find a match against something given, or can't reduce
 286       | otherwise
 287       = ReduceMe AddToIrreds
 288
 289     complain dict = mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 290                     addNoInstanceErr str givens dict
 291 \end{code}
 292
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsection{Data types for the reduction mechanism}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 The main control over context reduction is here
 301
 302 \begin{code}
 303 data WhatToDo
 304  = ReduceMe               -- Try to reduce this
 305         NoInstanceAction  -- What to do if there's no such instance
 306
 307  | DontReduce             -- Return as irreducible
 308
 309  | Free                   -- Return as free
 310
 311  | FreeIfTautological     -- Return as free iff it's tautological;
 312                           -- if not, return as irreducible
 313
 314 data NoInstanceAction
 315   = Stop                -- Fail; no error message
 316                         -- (Only used when tautology checking.)
 317
 318   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 319                         -- produce an error message of any kind.
 320                         -- It might be quite legitimate such as (Eq a)!
 321 \end{code}
 322
 323
 324
 325 \begin{code}
 326 type RedState s
 327   = (Avails s,          -- What's available
 328      [Inst s],          -- Insts for which try_me returned Free
 329      [Inst s]           -- Insts for which try_me returned DontReduce
 330     )
 331
 332 type Avails s = FiniteMap (Inst s) (Avail s)
 333
 334 data Avail s
 335   = Avail
 336         (TcIdOcc s)     -- The "main Id"; that is, the Id for the Inst that
 337                         -- caused this avail to be put into the finite map in the first place
 338                         -- It is this Id that is bound to the RHS.
 339
 340         (RHS s)         -- The RHS: an expression whose value is that Inst.
 341                         -- The main Id should be bound to this RHS
 342
 343         [TcIdOcc s]     -- Extra Ids that must all be bound to the main Id.
 344                         -- At the end we generate a list of bindings
 345                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 346
 347 data RHS s
 348   = NoRhs               -- Used for irreducible dictionaries,
 349                         -- which are going to be lambda bound, or for those that are
 350                         -- suppplied as "given" when checking againgst a signature.
 351                         --
 352                         -- NoRhs is also used for Insts like (CCallable f)
 353                         -- where no witness is required.
 354
 355   | Rhs                 -- Used when there is a RHS
 356         (TcExpr s)
 357         Bool            -- True => the RHS simply selects a superclass dictionary
 358                         --         from a subclass dictionary.
 359                         -- False => not so.
 360                         -- This is useful info, because superclass selection
 361                         -- is cheaper than building the dictionary using its dfun,
 362                         -- and we can sometimes replace the latter with the former
 363
 364   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 365                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 366                         -- the finite map, with an PassiveScSel.  Then if the
 367                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 368         (TcExpr s)
 369         [Inst s]        -- List of Insts that are free in the RHS.
 370                         -- If the main Id is subsequently needed, we toss this list into
 371                         -- the needed-inst pool so that we make sure their bindings
 372                         -- will actually be produced.
 373                         --
 374                         -- Invariant: these Insts are already in the finite mapping
 375
 376
 377 pprAvails avails = vcat (map pp (eltsFM avails))
 378   where
 379     pp (Avail main_id rhs ids)
 380       = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 381
 382 pprRhs NoRhs = text "<no rhs>"
 383 pprRhs (Rhs rhs b) = ppr rhs
 384 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 385 \end{code}
 386
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsection[reduce]{@reduce@}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 The main entry point for context reduction is @reduceContext@:
 395
 396 \begin{code}
 397 reduceContext :: SDoc -> (Inst s -> WhatToDo)
 398               -> [Inst s]       -- Given
 399               -> [Inst s]       -- Wanted
 400               -> TcM s (TcDictBinds s,
 401                         [Inst s],               -- Free
 402                         [Inst s])               -- Irreducible
 403
 404 reduceContext str try_me givens wanteds
 405   =     -- Zonking first
 406     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 407     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 408
 409 {-
 410     pprTrace "reduceContext" (vcat [
 411              text "----------------------",
 412              str,
 413              text "given" <+> ppr givens,
 414              text "wanted" <+> ppr wanteds,
 415              text "----------------------"
 416              ]) $
 417 -}
 418         -- Build the Avail mapping from "givens"
 419     foldlNF_Tc addGiven emptyFM givens          `thenNF_Tc` \ avails ->
 420
 421         -- Do the real work
 422     reduceList (0,[]) try_me wanteds (avails, [], [])   `thenTc` \ (avails, frees, irreds) ->
 423
 424         -- Extract the bindings from avails
 425     let
 426        binds = foldFM add_bind EmptyMonoBinds avails
 427
 428        add_bind _ (Avail main_id rhs ids) binds
 429          = foldr add_synonym (add_rhs_bind rhs binds) ids
 430          where
 431            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 432            add_rhs_bind other       binds = binds
 433
 434            -- Add the trivial {x = y} bindings
 435            -- The main Id can end up in the list when it's first added passively
 436            -- and then activated, so we have to filter it out.  A bit of a hack.
 437            add_synonym id binds
 438              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 439              | otherwise     = binds
 440     in
 441 {-
 442     pprTrace ("reduceContext end") (vcat [
 443              text "----------------------",
 444              str,
 445              text "given" <+> ppr givens,
 446              text "wanted" <+> ppr wanteds,
 447              text "----",
 448              text "avails" <+> pprAvails avails,
 449              text "irreds" <+> ppr irreds,
 450              text "----------------------"
 451              ]) $
 452 -}
 453     returnTc (binds, frees, irreds)
 454 \end{code}
 455
 456 The main context-reduction function is @reduce@.  Here's its game plan.
 457
 458 \begin{code}
 459 reduceList :: (Int,[Inst s])
 460            -> (Inst s -> WhatToDo)
 461            -> [Inst s]
 462            -> RedState s
 463            -> TcM s (RedState s)
 464 \end{code}
 465
 466 @reduce@ is passed
 467      try_me:    given an inst, this function returns
 468                   Reduce       reduce this
 469                   DontReduce   return this in "irreds"
 470                   Free         return this in "frees"
 471
 472      wanteds:   The list of insts to reduce
 473      state:     An accumulating parameter of type RedState
 474                 that contains the state of the algorithm
 475
 476   It returns a RedState.
 477
 478
 479 \begin{code}
 480 reduceList (n,stack) try_me wanteds state
 481   | n > opt_MaxContextReductionDepth
 482   = failWithTc (reduceDepthErr n stack)
 483
 484   | otherwise
 485   =
 486 #ifdef DEBUG
 487    (if n > 4 then
 488         pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
 489     else (\x->x))
 490 #endif
 491     go wanteds state
 492   where
 493     go []     state = returnTc state
 494     go (w:ws) state = reduce (n+1, w:stack) try_me w state      `thenTc` \ state' ->
 495                       go ws state'
 496
 497     -- Base case: we're done!
 498 reduce stack try_me wanted state@(avails, frees, irreds)
 499
 500     -- It's the same as an existing inst, or a superclass thereof
 501   | wanted `elemFM` avails
 502   = returnTc (activate avails wanted, frees, irreds)
 503
 504     -- It should be reduced
 505   | case try_me_result of { ReduceMe _ -> True; _ -> False }
 506   = lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 507
 508     case lookup_result of
 509       GenInst wanteds' rhs -> use_instance wanteds' rhs
 510       SimpleInst rhs       -> use_instance []       rhs
 511
 512       NoInstance ->    -- No such instance!
 513                        -- Decide what to do based on the no_instance_action requested
 514                  case no_instance_action of
 515                    Stop        -> failTc        -- Fail
 516                    AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds
 517
 518     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 519   | case try_me_result of { Free -> True; _ -> False }
 520   =     -- First, see if the inst can be reduced to a constant in one step
 521     lookupInst wanted     `thenNF_Tc` \ lookup_result ->
 522     case lookup_result of
 523        SimpleInst rhs -> use_instance [] rhs
 524        other          -> add_to_frees
 525
 526     -- It's free and this is a top level binding, so
 527     -- check whether it's a tautology or not
 528   | case try_me_result of { FreeIfTautological -> True; _ -> False }
 529   =     -- Try for tautology
 530     tryTc
 531           -- If tautology trial fails, add to irreds
 532           (addGiven avails wanted      `thenNF_Tc` \ avails' ->
 533            returnTc (avails', frees, wanted:irreds))
 534
 535           -- If tautology succeeds, just add to frees
 536           (reduce stack try_me_taut wanted (avails, [], [])             `thenTc_`
 537            returnTc (avails, wanted:frees, irreds))
 538
 539
 540     -- It's irreducible (or at least should not be reduced)
 541   | otherwise
 542   = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
 543         -- See if the inst can be reduced to a constant in one step
 544     lookupInst wanted     `thenNF_Tc` \ lookup_result ->
 545     case lookup_result of
 546        SimpleInst rhs -> use_instance [] rhs
 547        other          -> add_to_irreds
 548
 549   where
 550         -- The three main actions
 551     add_to_frees  = let
 552                         avails' = addFree avails wanted
 553                         -- Add the thing to the avails set so any identical Insts
 554                         -- will be commoned up with it right here
 555                     in
 556                     returnTc (avails', wanted:frees, irreds)
 557
 558     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 559                     returnTc (avails',  frees, wanted:irreds)
 560
 561     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 562                                 reduceList stack try_me wanteds' (avails', frees, irreds)
 563
 564     try_me_result               = try_me wanted
 565     ReduceMe no_instance_action = try_me_result
 566
 567     -- The try-me to use when trying to identify tautologies
 568     -- It blunders on reducing as much as possible
 569     try_me_taut inst = ReduceMe Stop    -- No error recovery
 570 \end{code}
 571
 572
 573 \begin{code}
 574 activate :: Avails s -> Inst s -> Avails s
 575          -- Activate the binding for Inst, ensuring that a binding for the
 576          -- wanted Inst will be generated.
 577          -- (Activate its parent if necessary, recursively).
 578          -- Precondition: the Inst is in Avails already
 579
 580 activate avails wanted
 581   | not (instBindingRequired wanted)
 582   = avails
 583
 584   | otherwise
 585   = case lookupFM avails wanted of
 586
 587       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 588                foldl activate avails' insts      -- Activate anything it needs
 589              where
 590                avails' = addToFM avails wanted avail'
 591                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 592
 593       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 594                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 595
 596       Nothing -> panic "activate"
 597   where
 598       wanted_id = instToId wanted
 599
 600 addWanted avails wanted rhs_expr
 601   = ASSERT( not (wanted `elemFM` avails) )
 602     returnNF_Tc (addToFM avails wanted avail)
 603         -- NB: we don't add the thing's superclasses too!
 604         -- Why not?  Because addWanted is used when we've successfully used an
 605         -- instance decl to reduce something; e.g.
 606         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 607         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 608         -- If we put the superclasses of "d" in avails, then we might end up
 609         -- expressing "d1" in terms of "d", which would be a disaster.
 610   where
 611     avail = Avail (instToId wanted) rhs []
 612
 613     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 614         | otherwise                  = NoRhs
 615
 616 addFree :: Avails s -> Inst s -> (Avails s)
 617         -- When an Inst is tossed upstairs as 'free' we nevertheless add it
 618         -- to avails, so that any other equal Insts will be commoned up right
 619         -- here rather than also being tossed upstairs.
 620 addFree avails free
 621   | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
 622   | otherwise   = avails
 623
 624 addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
 625 addGiven avails given
 626   =      -- ASSERT( not (given `elemFM` avails) )
 627          -- This assertion isn't necessarily true.  It's permitted
 628          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 629          -- and when typechecking instance decls we generate redundant "givens" too.
 630     addAvail avails given avail
 631   where
 632     avail = Avail (instToId given) NoRhs []
 633
 634 addAvail avails wanted avail
 635   = addSuperClasses (addToFM avails wanted avail) wanted
 636
 637 addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
 638                 -- Add all the superclasses of the Inst to Avails
 639                 -- Invariant: the Inst is already in Avails.
 640
 641 addSuperClasses avails dict
 642   | not (isDict dict)
 643   = returnNF_Tc avails
 644
 645   | otherwise   -- It is a dictionary
 646   = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
 647   where
 648     (clas, tys) = getDictClassTys dict
 649
 650     (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
 651     sc_theta' = substFlexiTheta (zipVarEnv tyvars tys) sc_theta
 652
 653     add_sc avails ((super_clas, super_tys), sc_sel)
 654       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 655         let
 656            sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
 657                                        tys)
 658                                 [instToId dict]
 659         in
 660         case lookupFM avails super_dict of
 661
 662              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 663                   -- Already there, but not as a superclass selector
 664                   -- No need to look at its superclasses; since it's there
 665                   --    already they must be already in avails
 666                   -- However, we must remember to activate the dictionary
 667                   -- from which it is (now) generated
 668                   returnNF_Tc (activate avails' dict)
 669                 where
 670                   avails' = addToFM avails super_dict avail
 671                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 672
 673              Just (Avail _ _ _) -> returnNF_Tc avails
 674                   -- Already there; no need to do anything
 675
 676              Nothing ->
 677                   -- Not there at all, so add it, and its superclasses
 678                   addAvail avails super_dict avail
 679                 where
 680                   avail   = Avail (instToId super_dict)
 681                                   (PassiveScSel sc_sel_rhs [dict])
 682                                   []
 683 \end{code}
 684
 685 %************************************************************************
 686 %*                                                                      *
 687 \subsection[simple]{@Simple@ versions}
 688 %*                                                                      *
 689 %************************************************************************
 690
 691 Much simpler versions when there are no bindings to make!
 692
 693 @tcSimplifyThetas@ simplifies class-type constraints formed by
 694 @deriving@ declarations and when specialising instances.  We are
 695 only interested in the simplified bunch of class/type constraints.
 696
 697 It simplifies to constraints of the form (C a b c) where
 698 a,b,c are type variables.  This is required for the context of
 699 instance declarations.
 700
 701 \begin{code}
 702 tcSimplifyThetas :: (Class -> ClassInstEnv)             -- How to find the ClassInstEnv
 703                  -> ThetaType                           -- Wanted
 704                  -> TcM s ThetaType                     -- Needed; of the form C a b c
 705                                                         -- where a,b,c are type variables
 706
 707 tcSimplifyThetas inst_mapper wanteds
 708   = reduceSimple inst_mapper [] wanteds         `thenNF_Tc` \ irreds ->
 709     let
 710         -- Check that the returned dictionaries are of the form (C a b c)
 711         bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
 712                                            isEmptyVarSet (tyVarsOfTypes tys)]
 713                  | otherwise       = [ct | ct@(clas,tys) <- irreds,
 714                                            not (all isTyVarTy tys)]
 715
 716     in
 717     if null bad_guys then
 718         returnTc irreds
 719     else
 720        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 721        failTc
 722 \end{code}
 723
 724 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 725 used with \tr{default} declarations.  We are only interested in
 726 whether it worked or not.
 727
 728 \begin{code}
 729 tcSimplifyCheckThetas :: ThetaType      -- Given
 730                       -> ThetaType      -- Wanted
 731                       -> TcM s ()
 732
 733 tcSimplifyCheckThetas givens wanteds
 734   = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`     \ irreds ->
 735     if null irreds then
 736        returnTc ()
 737     else
 738        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 739        failTc
 740 \end{code}
 741
 742
 743 \begin{code}
 744 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
 745                     -- True  => irreducible
 746                     -- False => given, or can be derived from a given or from an irreducible
 747
 748 reduceSimple :: (Class -> ClassInstEnv)
 749              -> ThetaType               -- Given
 750              -> ThetaType               -- Wanted
 751              -> NF_TcM s ThetaType      -- Irreducible
 752
 753 reduceSimple inst_mapper givens wanteds
 754   = reduce_simple (0,[]) inst_mapper givens_fm wanteds  `thenNF_Tc` \ givens_fm' ->
 755     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 756   where
 757     givens_fm     = foldl addNonIrred emptyFM givens
 758
 759 reduce_simple :: (Int,ThetaType)                -- Stack
 760               -> (Class -> ClassInstEnv)
 761               -> AvailsSimple
 762               -> ThetaType
 763               -> NF_TcM s AvailsSimple
 764
 765 reduce_simple (n,stack) inst_mapper avails wanteds
 766   = go avails wanteds
 767   where
 768     go avails []     = returnNF_Tc avails
 769     go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w    `thenNF_Tc` \ avails' ->
 770                        go avails' ws
 771
 772 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
 773   | wanted `elemFM` givens
 774   = returnNF_Tc givens
 775
 776   | otherwise
 777   = lookupSimpleInst (inst_mapper clas) clas tys        `thenNF_Tc` \ maybe_theta ->
 778
 779     case maybe_theta of
 780       Nothing ->    returnNF_Tc (addIrred givens wanted)
 781       Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
 782
 783 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 784 addIrred givens ct
 785   = addSCs (addToFM givens ct True) ct
 786
 787 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 788 addNonIrred givens ct
 789   = addSCs (addToFM givens ct False) ct
 790
 791 addSCs givens ct@(clas,tys)
 792  = foldl add givens sc_theta
 793  where
 794    (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
 795    sc_theta = substFlexiTheta (zipVarEnv tyvars tys) sc_theta_tmpl
 796
 797    add givens ct = case lookupFM givens ct of
 798                            Nothing    -> -- Add it and its superclasses
 799                                          addSCs (addToFM givens ct False) ct
 800
 801                            Just True  -> -- Set its flag to False; superclasses already done
 802                                          addToFM givens ct False
 803
 804                            Just False -> -- Already done
 805                                          givens
 806
 807 \end{code}
 808
 809 %************************************************************************
 810 %*                                                                      *
 811 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 812 %*                                                                      *
 813 %************************************************************************
 814
 815 When doing a binding group, we may have @Insts@ of local functions.
 816 For example, we might have...
 817 \begin{verbatim}
 818 let f x = x + 1     -- orig local function (overloaded)
 819     f.1 = f Int     -- two instances of f
 820     f.2 = f Float
 821  in
 822     (f.1 5, f.2 6.7)
 823 \end{verbatim}
 824 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 825 where @f@ is in scope; those @Insts@ must certainly not be passed
 826 upwards towards the top-level.  If the @Insts@ were binding-ified up
 827 there, they would have unresolvable references to @f@.
 828
 829 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 830 For each method @Inst@ in the @init_lie@ that mentions one of the
 831 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 832 @LIE@), as well as the @HsBinds@ generated.
 833
 834 \begin{code}
 835 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
 836
 837 bindInstsOfLocalFuns init_lie local_ids
 838   | null overloaded_ids || null lie_for_here
 839         -- Common case
 840   = returnTc (init_lie, EmptyMonoBinds)
 841
 842   | otherwise
 843   = reduceContext (text "bindInsts" <+> ppr local_ids)
 844                   try_me [] lie_for_here        `thenTc` \ (binds, frees, irreds) ->
 845     ASSERT( null irreds )
 846     returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
 847   where
 848     overloaded_ids = filter is_overloaded local_ids
 849     is_overloaded id = case splitSigmaTy (idType id) of
 850                           (_, theta, _) -> not (null theta)
 851
 852     overloaded_set = mkVarSet overloaded_ids    -- There can occasionally be a lot of them
 853                                                 -- so it's worth building a set, so that
 854                                                 -- lookup (in isMethodFor) is faster
 855
 856         -- No sense in repeatedly zonking lots of
 857         -- constant constraints so filter them out here
 858     (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
 859                                                  (bagToList init_lie)
 860     try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
 861                 | otherwise                       = Free
 862 \end{code}
 863
 864
 865 %************************************************************************
 866 %*                                                                      *
 867 \section[Disambig]{Disambiguation of overloading}
 868 %*                                                                      *
 869 %************************************************************************
 870
 871
 872 If a dictionary constrains a type variable which is
 873 \begin{itemize}
 874 \item
 875 not mentioned in the environment
 876 \item
 877 and not mentioned in the type of the expression
 878 \end{itemize}
 879 then it is ambiguous. No further information will arise to instantiate
 880 the type variable; nor will it be generalised and turned into an extra
 881 parameter to a function.
 882
 883 It is an error for this to occur, except that Haskell provided for
 884 certain rules to be applied in the special case of numeric types.
 885
 886 Specifically, if
 887 \begin{itemize}
 888 \item
 889 at least one of its classes is a numeric class, and
 890 \item
 891 all of its classes are numeric or standard
 892 \end{itemize}
 893 then the type variable can be defaulted to the first type in the
 894 default-type list which is an instance of all the offending classes.
 895
 896 So here is the function which does the work.  It takes the ambiguous
 897 dictionaries and either resolves them (producing bindings) or
 898 complains.  It works by splitting the dictionary list by type
 899 variable, and using @disambigOne@ to do the real business.
 900
 901
 902 @tcSimplifyTop@ is called once per module to simplify
 903 all the constant and ambiguous Insts.
 904
 905 \begin{code}
 906 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
 907 tcSimplifyTop wanted_lie
 908   = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
 909     ASSERT( null frees )
 910
 911     let
 912                 -- All the non-std ones are definite errors
 913         (stds, non_stds) = partition isStdClassTyVarDict irreds
 914
 915
 916                 -- Group by type variable
 917         std_groups = equivClasses cmp_by_tyvar stds
 918
 919                 -- Pick the ones which its worth trying to disambiguate
 920         (std_oks, std_bads) = partition worth_a_try std_groups
 921                 -- Have a try at disambiguation
 922                 -- if the type variable isn't bound
 923                 -- up with one of the non-standard classes
 924         worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
 925         non_std_tyvars          = unionVarSets (map tyVarsOfInst non_stds)
 926
 927                 -- Collect together all the bad guys
 928         bad_guys = non_stds ++ concat std_bads
 929     in
 930
 931         -- Disambiguate the ones that look feasible
 932     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
 933
 934         -- And complain about the ones that don't
 935     mapNF_Tc complain bad_guys          `thenNF_Tc_`
 936
 937     returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
 938   where
 939     wanteds     = bagToList wanted_lie
 940     try_me inst = ReduceMe AddToIrreds
 941
 942     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
 943
 944     complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
 945                | otherwise                        = addAmbigErr tyVarsOfInst d
 946
 947 get_tv d   = case getDictClassTys d of
 948                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
 949 get_clas d = case getDictClassTys d of
 950                    (clas, [ty]) -> clas
 951 \end{code}
 952
 953 @disambigOne@ assumes that its arguments dictionaries constrain all
 954 the same type variable.
 955
 956 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
 957 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
 958 the most common use of defaulting is code like:
 959 \begin{verbatim}
 960         _ccall_ foo     `seqPrimIO` bar
 961 \end{verbatim}
 962 Since we're not using the result of @foo@, the result if (presumably)
 963 @void@.
 964
 965 \begin{code}
 966 disambigGroup :: [Inst s]       -- All standard classes of form (C a)
 967               -> TcM s (TcDictBinds s)
 968
 969 disambigGroup dicts
 970   |  any isNumericClass classes         -- Guaranteed all standard classes
 971   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 972         -- SO, TRY DEFAULT TYPES IN ORDER
 973
 974         -- Failure here is caused by there being no type in the
 975         -- default list which can satisfy all the ambiguous classes.
 976         -- For example, if Real a is reqd, but the only type in the
 977         -- default list is Int.
 978     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
 979     let
 980       try_default []    -- No defaults work, so fail
 981         = failTc
 982
 983       try_default (default_ty : default_tys)
 984         = tryTc (try_default default_tys) $     -- If default_ty fails, we try
 985                                                 -- default_tys instead
 986           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
 987           returnTc default_ty
 988         where
 989           thetas = classes `zip` repeat [default_ty]
 990     in
 991         -- See if any default works, and if so bind the type variable to it
 992         -- If not, add an AmbigErr
 993     recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds)     $
 994
 995     try_default default_tys                     `thenTc` \ chosen_default_ty ->
 996
 997         -- Bind the type variable and reduce the context, for real this time
 998     let
 999         chosen_default_tc_ty = typeToTcType chosen_default_ty   -- Tiresome!
1000     in
1001     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)   `thenTc_`
1002     reduceContext (text "disambig" <+> ppr dicts)
1003                   try_me [] dicts       `thenTc` \ (binds, frees, ambigs) ->
1004     ASSERT( null frees && null ambigs )
1005     returnTc binds
1006
1007   | all isCreturnableClass classes
1008   =     -- Default CCall stuff to (); we don't even both to check that () is an
1009         -- instance of CReturnable, because we know it is.
1010     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
1011     returnTc EmptyMonoBinds
1012
1013   | otherwise -- No defaults
1014   = complain dicts      `thenNF_Tc_`
1015     returnTc EmptyMonoBinds
1016
1017   where
1018     complain    = addAmbigErrs tyVarsOfInst
1019     try_me inst = ReduceMe AddToIrreds          -- This reduce should not fail
1020     tyvar       = get_tv (head dicts)           -- Should be non-empty
1021     classes     = map get_clas dicts
1022 \end{code}
1023
1024
1025
1026 Errors and contexts
1027 ~~~~~~~~~~~~~~~~~~~
1028 ToDo: for these error messages, should we note the location as coming
1029 from the insts, or just whatever seems to be around in the monad just
1030 now?
1031
1032 \begin{code}
1033 genCantGenErr insts     -- Can't generalise these Insts
1034   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1035          nest 4 (pprInstsInFull insts)
1036         ]
1037
1038 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1039
1040 addAmbigErr ambig_tv_fn dict
1041   = tcAddSrcLoc (instLoc dict) $
1042     addErrTcM (tidy_env,
1043                sep [text "Ambiguous type variable(s)" <+>
1044                         hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1045                    nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
1046                    nest 4 (pprOrigin dict)])
1047   where
1048     ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1049     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1050
1051 -- Used for top-level irreducibles
1052 addTopInstanceErr dict
1053   = tcAddSrcLoc (instLoc dict)                 $
1054     addErrTcM (tidy_env,
1055                sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
1056                    nest 4 $ pprOrigin dict])
1057   where
1058     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1059
1060 addNoInstanceErr str givens dict
1061   = tcAddSrcLoc (instLoc dict) $
1062     addErrTcM (tidy_env,
1063                sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1064                         nest 4 $ parens $ pprOrigin dict],
1065                    nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens]
1066               $$
1067               ptext SLIT("Probable cause:") <+>
1068               vcat [ptext SLIT("missing") <+> quotes (pprInst tidy_dict) <+> ptext SLIT("in") <+> str,
1069                     if all_tyvars then empty else
1070                     ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1071     )
1072   where
1073     all_tyvars = all isTyVarTy tys
1074     (_, tys)   = getDictClassTys dict
1075     (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1076
1077 -- Used for the ...Thetas variants; all top level
1078 addNoInstErr (c,ts)
1079   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1080
1081 reduceDepthErr n stack
1082   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1083           ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1084           nest 4 (pprInstsInFull stack)]
1085
1086 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
1087 \end{code}