ghc/compiler/typecheck/TcSimplify.lhs

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