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