2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcSimplify]{TcSimplify}
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
13 [DontReduce] otherwise see whether the inst is just a constant
15 if not, add original to context
16 This check gets rid of constant dictionaries without
19 If the inst does not constrain a local type variable then
20 [Free] then throw it out as free.
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)
31 If the inst constrains a local type variable, then
32 as for inference (local defns)
35 Checking (local defns)
37 If the inst constrains a local type variable then
38 [ReduceMe] reduce (signal error on failure)
40 If the inst does not constrain a local type variable then
41 [Free] throw it out as free.
45 If the inst constrains a local type variable then
46 as for checking (local defns)
48 If the inst does not constrain a local type variable then
49 as for checking (local defns)
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
59 otherwise [ReduceMe] always reduce
61 [NB: we may generate one Tree [Int] dict per module, so
62 sharing is not complete.]
64 Sort out ambiguity at the end.
71 f x = let g y = op (y::Int) in True
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
82 instance C (T a) Int where ...
83 instance C (T a) Bool where ...
85 and suppose we infer a context
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
93 forall x y. C (T x) y => <type not involving x>
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
100 Something similar can happen even if C constrains only ambiguous
101 variables. Suppose we infer the context
105 where x is ambiguous. Then we could infer the type
107 forall x. C [x] => <type not involving x>
109 in the hope that at the call site there was an instance
112 instance Num a => C [a] where ...
114 and hence the default mechanism would resolve the "a".
119 tcSimplify, tcSimplifyAndCheck,
120 tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
124 #include "HsVersions.h"
126 import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds )
127 import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
128 TcMonoBinds, TcDictBinds
132 import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
134 isTyVarDict, isDict, isStdClassTyVarDict, isMethodFor,
135 instToId, instBindingRequired, instCanBeGeneralised,
137 instLoc, getDictClassTys,
139 Inst(..), LIE, pprInsts, pprInstsInFull, mkLIE,
140 InstOrigin(..), pprOrigin
142 import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars )
143 import TcType ( TcType, TcTyVar, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
144 import Unify ( unifyTauTy )
145 import Id ( mkIdSet )
147 import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
148 snocBag, consBag, unionBags, isEmptyBag )
149 import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
150 import PrelInfo ( isNumericClass, isCcallishClass )
152 import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
153 import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
154 isTyVarTy, getTyVar_maybe, instantiateThetaTy
156 import PprType ( pprConstraint )
157 import TysWiredIn ( intTy, unitTy )
158 import TyVar ( elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
159 intersectTyVarSets, unionManyTyVarSets,
160 isEmptyTyVarSet, tyVarSetToList,
161 zipTyVarEnv, emptyTyVarEnv
164 import BasicTypes ( TopLevelFlag(..) )
165 import Unique ( Unique )
168 import List ( partition )
172 %************************************************************************
174 \subsection[tcSimplify-main]{Main entry function}
176 %************************************************************************
178 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
179 the ``don't-squash-consts'' flag set depending on top-level ness. For
180 top level defns we *do* squash constants, so that they stay local to a
181 single defn. This makes things which are inlined more likely to be
182 exportable, because their constants are "inside". Later passes will
183 float them out if poss, after inlinings are sorted out.
189 -> TcTyVarSet s -- ``Local'' type variables
191 -> TcM s (LIE s, -- Free
192 TcDictBinds s, -- Bindings
193 LIE s) -- Remaining wanteds; no dups
195 tcSimplify str top_lvl local_tvs wanteds
196 = tcSimpl str top_lvl local_tvs Nothing wanteds
199 @tcSimplifyAndCheck@ is similar to the above, except that it checks
200 that there is an empty wanted-set at the end. It may still return
201 some of constant insts, which have to be resolved finally at the end.
206 -> TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
209 -> TcM s (LIE s, -- Free
210 TcDictBinds s) -- Bindings
212 tcSimplifyAndCheck str local_tvs givens wanteds
213 = tcSimpl str top_lvl local_tvs (Just givens) wanteds `thenTc` \ (free_insts, binds, new_wanteds) ->
214 ASSERT( isEmptyBag new_wanteds )
215 returnTc (free_insts, binds)
217 top_lvl = error "tcSimplifyAndCheck" -- Never needed
223 -> TcTyVarSet s -- ``Local'' type variables
224 -- ASSERT: this tyvar set is already zonked
225 -> Maybe (LIE s) -- Given; these constrain only local tyvars
226 -- Nothing => just simplify
227 -- Just g => check that g entails wanteds
229 -> TcM s (LIE s, -- Free
230 TcMonoBinds s, -- Bindings
231 LIE s) -- Remaining wanteds; no dups
233 tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie
234 = -- ASSSERT: local_tvs are already zonked
235 reduceContext str try_me
237 (bagToList wanted_lie) `thenTc` \ (binds, frees, irreds) ->
239 -- Check for non-generalisable insts
241 cant_generalise = filter (not . instCanBeGeneralised) irreds
243 checkTc (null cant_generalise)
244 (genCantGenErr cant_generalise) `thenTc_`
247 returnTc (mkLIE frees, binds, mkLIE irreds)
249 givens = case maybe_given_lie of
250 Just given_lie -> bagToList given_lie
253 checking_against_signature = maybeToBool maybe_given_lie
254 is_top_level = case top_lvl of { TopLevel -> True; other -> False }
257 -- Does not constrain a local tyvar
258 | isEmptyTyVarSet (inst_tyvars `intersectTyVarSets` local_tvs)
259 = -- if not checking_against_signature && is_top_level then
260 -- FreeIfTautological -- Special case for inference on
261 -- -- top-level defns
266 -- When checking against a given signature we always reduce
267 -- until we find a match against something given, or can't reduce
268 | checking_against_signature
271 -- So we're infering (not checking) the type, and
272 -- the inst constrains a local type variable
274 = if isDict inst then
277 ReduceMe CarryOn -- Lits and Methods
280 inst_tyvars = tyVarsOfInst inst
285 %************************************************************************
287 \subsection{Data types for the reduction mechanism}
289 %************************************************************************
291 The main control over context reduction is here
295 = ReduceMe -- Reduce this
296 NoInstanceAction -- What to do if there's no such instance
298 | DontReduce -- Return as irreducible
300 | Free -- Return as free
302 | FreeIfTautological -- Return as free iff it's tautological;
303 -- if not, return as irreducible
305 data NoInstanceAction
306 = CarryOn -- Produce an error message, but keep on with next inst
308 | Stop -- Produce an error message and stop reduction
310 | AddToIrreds -- Just add the inst to the irreductible ones; don't
311 -- produce an error message of any kind.
312 -- It might be quite legitimate
320 = (Avails s, -- What's available
321 [Inst s], -- Insts for which try_me returned Free
322 [Inst s] -- Insts for which try_me returned DontReduce
325 type Avails s = FiniteMap (Inst s) (Avail s)
329 (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that
330 -- caused this avail to be put into the finite map in the first place
331 -- It is this Id that is bound to the RHS.
333 (RHS s) -- The RHS: an expression whose value is that Inst.
334 -- The main Id should be bound to this RHS
336 [TcIdOcc s] -- Extra Ids that must all be bound to the main Id.
337 -- At the end we generate a list of bindings
338 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
341 = NoRhs -- Used for irreducible dictionaries,
342 -- which are going to be lambda bound, or for those that are
343 -- suppplied as "given" when checking againgst a signature.
345 -- NoRhs is also used for Insts like (CCallable f)
346 -- where no witness is required.
348 | Rhs -- Used when there is a RHS
350 Bool -- True => the RHS simply selects a superclass dictionary
351 -- from a subclass dictionary.
353 -- This is useful info, because superclass selection
354 -- is cheaper than building the dictionary using its dfun,
355 -- and we can sometimes replace the latter with the former
357 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
358 -- an (Ord t) dictionary; then we put an (Eq t) entry in
359 -- the finite map, with an PassiveScSel. Then if the
360 -- the (Eq t) binding is ever *needed* we make it an Rhs
362 [Inst s] -- List of Insts that are free in the RHS.
363 -- If the main Id is subsequently needed, we toss this list into
364 -- the needed-inst pool so that we make sure their bindings
365 -- will actually be produced.
367 -- Invariant: these Insts are already in the finite mapping
370 pprAvails avails = vcat (map pp (eltsFM avails))
372 pp (Avail main_id rhs ids)
373 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
375 pprRhs NoRhs = text "<no rhs>"
376 pprRhs (Rhs rhs b) = ppr rhs
377 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
381 %************************************************************************
383 \subsection[reduce]{@reduce@}
385 %************************************************************************
387 The main entry point for context reduction is @reduceContext@:
390 reduceContext :: SDoc -> (Inst s -> WhatToDo)
392 -> [Inst s] -- Wanted
393 -> TcM s (TcDictBinds s, [Inst s], [Inst s])
395 reduceContext str try_me givens wanteds
397 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
398 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
401 pprTrace "reduceContext" (vcat [
402 text "----------------------",
404 text "given" <+> ppr givens,
405 text "wanted" <+> ppr wanteds,
406 text "----------------------"
410 -- Build the Avail mapping from "givens"
411 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
414 reduce try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
416 -- Extract the bindings from avails
418 binds = foldFM add_bind EmptyMonoBinds avails
420 add_bind _ (Avail main_id rhs ids) binds
421 = foldr add_synonym (add_rhs_bind rhs binds) ids
423 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
424 add_rhs_bind other binds = binds
426 -- Add the trivial {x = y} bindings
427 -- The main Id can end up in the list when it's first added passively
428 -- and then activated, so we have to filter it out. A bit of a hack.
430 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
434 pprTrace ("reduceContext1") (vcat [
435 text "----------------------",
437 text "given" <+> ppr givens,
438 text "wanted" <+> ppr wanteds,
441 text "----------------------"
444 returnTc (binds, frees, irreds)
447 The main context-reduction function is @reduce@. Here's its game plan.
450 reduce :: (Inst s -> WhatToDo)
453 -> TcM s (RedState s)
457 try_me: given an inst, this function returns
459 DontReduce return this in "irreds"
460 Free return this in "frees"
462 wanteds: The list of insts to reduce
463 state: An accumulating parameter of type RedState
464 that contains the state of the algorithm
466 It returns a RedState.
470 -- Base case: we're done!
471 reduce try_me [] state = returnTc state
473 reduce try_me (wanted:wanteds) state@(avails, frees, irreds)
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)
479 -- It should be reduced
480 | case try_me_result of { ReduceMe _ -> True; _ -> False }
481 = lookupInst wanted `thenNF_Tc` \ lookup_result ->
483 case lookup_result of
484 GenInst wanteds' rhs -> use_instance wanteds' rhs
485 SimpleInst rhs -> use_instance [] rhs
487 NoInstance -> -- No such instance!
488 -- Decide what to do based on the no_instance_action requested
489 case no_instance_action of
491 addNoInstanceErr wanted `thenNF_Tc_`
494 CarryOn -> -- Carry on.
495 -- Add the bad guy to the avails to suppress similar
496 -- messages from other insts in wanteds
497 addNoInstanceErr wanted `thenNF_Tc_`
498 addGiven avails wanted `thenNF_Tc` \ avails' ->
499 reduce try_me wanteds (avails', frees, irreds) -- Carry on
501 AddToIrreds -> -- Add the offending insts to the irreds
506 -- It's free and this isn't a top-level binding, so just chuck it upstairs
507 | case try_me_result of { Free -> True; _ -> False }
508 = -- First, see if the inst can be reduced to a constant in one step
509 lookupInst wanted `thenNF_Tc` \ lookup_result ->
510 case lookup_result of
511 SimpleInst rhs -> use_instance [] rhs
512 other -> add_to_frees
514 -- It's free and this is a top level binding, so
515 -- check whether it's a tautology or not
516 | case try_me_result of { FreeIfTautological -> True; _ -> False }
517 = -- Try for tautology
519 -- If tautology trial fails, add to irreds
520 (addGiven avails wanted `thenNF_Tc` \ avails' ->
521 returnTc (avails', frees, wanted:irreds))
523 -- If tautology succeeds, just add to frees
524 (reduce try_me_taut [wanted] (avails, [], []) `thenTc_`
525 returnTc (avails, wanted:frees, irreds))
527 reduce try_me wanteds state'
530 -- It's irreducible (or at least should not be reduced)
532 = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
533 -- See if the inst can be reduced to a constant in one step
534 lookupInst wanted `thenNF_Tc` \ lookup_result ->
535 case lookup_result of
536 SimpleInst rhs -> use_instance [] rhs
537 other -> add_to_irreds
540 -- The three main actions
541 add_to_frees = reduce try_me wanteds (avails, wanted:frees, irreds)
543 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
544 reduce try_me wanteds (avails', frees, wanted:irreds)
546 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
547 reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds)
550 try_me_result = try_me wanted
551 ReduceMe no_instance_action = try_me_result
553 -- The try-me to use when trying to identify tautologies
554 -- It blunders on reducing as much as possible
555 try_me_taut inst = ReduceMe Stop -- No error recovery
560 activate :: Avails s -> Inst s -> Avails s
561 -- Activate the binding for Inst, ensuring that a binding for the
562 -- wanted Inst will be generated.
563 -- (Activate its parent if necessary, recursively).
564 -- Precondition: the Inst is in Avails already
566 activate avails wanted
567 | not (instBindingRequired wanted)
571 = case lookupFM avails wanted of
573 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
574 foldl activate avails' insts -- Activate anything it needs
576 avails' = addToFM avails wanted avail'
577 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
579 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
580 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
582 Nothing -> panic "activate"
584 wanted_id = instToId wanted
586 addWanted avails wanted rhs_expr
587 = ASSERT( not (wanted `elemFM` avails) )
588 returnNF_Tc (addToFM avails wanted avail)
589 -- NB: we don't add the thing's superclasses too!
590 -- Why not? Because addWanted is used when we've successfully used an
591 -- instance decl to reduce something; e.g.
592 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
593 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
594 -- If we put the superclasses of "d" in avails, then we might end up
595 -- expressing "d1" in terms of "d", which would be a disaster.
597 avail = Avail (instToId wanted) rhs []
599 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
602 addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
603 addGiven avails given
604 = -- ASSERT( not (given `elemFM` avails) )
605 -- This assertion isn' necessarily true. It's permitted
606 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
607 -- and when typechecking instance decls we generate redundant "givens" too.
608 addAvail avails given avail
610 avail = Avail (instToId given) NoRhs []
612 addAvail avails wanted avail
613 = addSuperClasses (addToFM avails wanted avail) wanted
615 addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
616 -- Add all the superclasses of the Inst to Avails
617 -- Invariant: the Inst is already in Avails.
619 addSuperClasses avails dict
623 | otherwise -- It is a dictionary
624 = tcInstTheta env sc_theta `thenNF_Tc` \ sc_theta' ->
625 foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
627 (clas, tys) = getDictClassTys dict
629 (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
630 env = zipTyVarEnv tyvars tys
632 add_sc avails ((super_clas, super_tys), sc_sel)
633 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
635 sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
639 case lookupFM avails super_dict of
641 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
642 -- Already there, but not as a superclass selector
643 -- No need to look at its superclasses; since it's there
644 -- already they must be already in avails
645 -- However, we must remember to activate the dictionary
646 -- from which it is (now) generated
647 returnNF_Tc (activate avails' dict)
649 avails' = addToFM avails super_dict avail
650 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
652 Just (Avail _ _ _) -> returnNF_Tc avails
653 -- Already there; no need to do anything
656 -- Not there at all, so add it, and its superclasses
657 addAvail avails super_dict avail
659 avail = Avail (instToId super_dict)
660 (PassiveScSel sc_sel_rhs [dict])
664 %************************************************************************
666 \subsection[simple]{@Simple@ versions}
668 %************************************************************************
670 Much simpler versions when there are no bindings to make!
672 @tcSimplifyThetas@ simplifies class-type constraints formed by
673 @deriving@ declarations and when specialising instances. We are
674 only interested in the simplified bunch of class/type constraints.
676 It simplifies to constraints of the form (C a b c) where
677 a,b,c are type variables. This is required for the context of
678 instance declarations.
681 tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
682 -> ThetaType -- Wanted
683 -> TcM s ThetaType -- Needed; of the form C a b c
684 -- where a,b,c are type variables
686 tcSimplifyThetas inst_mapper wanteds
687 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
689 -- Check that the returned dictionaries are of the form (C a b c)
690 bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)]
692 if null bad_guys then
695 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
699 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
700 used with \tr{default} declarations. We are only interested in
701 whether it worked or not.
704 tcSimplifyCheckThetas :: ThetaType -- Given
705 -> ThetaType -- Wanted
708 tcSimplifyCheckThetas givens wanteds
709 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
713 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
716 addNoInstErr (c,ts) = addErrTc (noDictInstanceErr c ts)
721 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
722 -- True => irreducible
723 -- False => given, or can be derived from a given or from an irreducible
725 reduceSimple :: (Class -> ClassInstEnv)
726 -> ThetaType -- Given
727 -> ThetaType -- Wanted
728 -> NF_TcM s ThetaType -- Irreducible
730 reduceSimple inst_mapper givens wanteds
731 = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
732 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
734 givens_fm = foldl addNonIrred emptyFM givens
736 reduce_simple :: (Class -> ClassInstEnv)
739 -> NF_TcM s AvailsSimple
741 reduce_simple inst_mapper givens []
742 = -- Finished, so pull out the needed ones
745 reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds)
746 | wanted `elemFM` givens
747 = reduce_simple inst_mapper givens wanteds
750 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
753 Nothing -> reduce_simple inst_mapper (addIrred givens wanted) wanteds
754 Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds)
756 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
758 = addSCs (addToFM givens ct True) ct
760 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
761 addNonIrred givens ct
762 = addSCs (addToFM givens ct False) ct
764 addSCs givens ct@(clas,tys)
765 = foldl add givens sc_theta
767 (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
768 sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl
770 add givens ct = case lookupFM givens ct of
771 Nothing -> -- Add it and its superclasses
772 addSCs (addToFM givens ct False) ct
774 Just True -> -- Set its flag to False; superclasses already done
775 addToFM givens ct False
777 Just False -> -- Already done
782 %************************************************************************
784 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
786 %************************************************************************
788 When doing a binding group, we may have @Insts@ of local functions.
789 For example, we might have...
791 let f x = x + 1 -- orig local function (overloaded)
792 f.1 = f Int -- two instances of f
797 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
798 where @f@ is in scope; those @Insts@ must certainly not be passed
799 upwards towards the top-level. If the @Insts@ were binding-ified up
800 there, they would have unresolvable references to @f@.
802 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
803 For each method @Inst@ in the @init_lie@ that mentions one of the
804 @Ids@, we create a binding. We return the remaining @Insts@ (in an
805 @LIE@), as well as the @HsBinds@ generated.
808 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
810 bindInstsOfLocalFuns init_lie local_ids
811 = reduceContext (text "bindInsts" <+> ppr local_ids)
812 try_me [] (bagToList init_lie) `thenTc` \ (binds, frees, irreds) ->
813 ASSERT( null irreds )
814 returnTc (mkLIE frees, binds)
816 local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them
817 -- so it's worth building a set, so that
818 -- lookup (in isMethodFor) is faster
819 try_me inst | isMethodFor local_id_set inst = ReduceMe CarryOn
824 %************************************************************************
826 \section[Disambig]{Disambiguation of overloading}
828 %************************************************************************
831 If a dictionary constrains a type variable which is
834 not mentioned in the environment
836 and not mentioned in the type of the expression
838 then it is ambiguous. No further information will arise to instantiate
839 the type variable; nor will it be generalised and turned into an extra
840 parameter to a function.
842 It is an error for this to occur, except that Haskell provided for
843 certain rules to be applied in the special case of numeric types.
848 at least one of its classes is a numeric class, and
850 all of its classes are numeric or standard
852 then the type variable can be defaulted to the first type in the
853 default-type list which is an instance of all the offending classes.
855 So here is the function which does the work. It takes the ambiguous
856 dictionaries and either resolves them (producing bindings) or
857 complains. It works by splitting the dictionary list by type
858 variable, and using @disambigOne@ to do the real business.
861 @tcSimplifyTop@ is called once per module to simplify
862 all the constant and ambiguous Insts.
865 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
866 tcSimplifyTop wanteds
867 = reduceContext (text "tcSimplTop") try_me [] (bagToList wanteds) `thenTc` \ (binds1, frees, irreds) ->
871 -- All the non-std ones are definite errors
872 (stds, non_stds) = partition isStdClassTyVarDict irreds
875 -- Group by type variable
876 std_groups = equivClasses cmp_by_tyvar stds
878 -- Pick the ones which its worth trying to disambiguate
879 (std_oks, std_bads) = partition worth_a_try std_groups
880 -- Have a try at disambiguation
881 -- if the type variable isn't bound
882 -- up with one of the non-standard classes
883 worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars)
884 non_std_tyvars = unionManyTyVarSets (map tyVarsOfInst non_stds)
886 -- Collect together all the bad guys
887 bad_guys = non_stds ++ concat std_bads
890 -- Disambiguate the ones that look feasible
891 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
893 -- And complain about the ones that don't
894 mapNF_Tc complain bad_guys `thenNF_Tc_`
896 returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
898 try_me inst = ReduceMe AddToIrreds
900 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
902 complain d | isEmptyTyVarSet (tyVarsOfInst d) = addNoInstanceErr d
903 | otherwise = addAmbigErr [d]
905 get_tv d = case getDictClassTys d of
906 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
907 get_clas d = case getDictClassTys d of
911 @disambigOne@ assumes that its arguments dictionaries constrain all
912 the same type variable.
914 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
915 @()@ instead of @Int@. I reckon this is the Right Thing to do since
916 the most common use of defaulting is code like:
918 _ccall_ foo `seqPrimIO` bar
920 Since we're not using the result of @foo@, the result if (presumably)
924 disambigGroup :: [Inst s] -- All standard classes of form (C a)
925 -> TcM s (TcDictBinds s)
928 | any isNumericClass classes -- Guaranteed all standard classes
929 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
930 -- SO, TRY DEFAULT TYPES IN ORDER
932 -- Failure here is caused by there being no type in the
933 -- default list which can satisfy all the ambiguous classes.
934 -- For example, if Real a is reqd, but the only type in the
935 -- default list is Int.
936 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
938 try_default [] -- No defaults work, so fail
941 try_default (default_ty : default_tys)
942 = tryTc (try_default default_tys) $ -- If default_ty fails, we try
943 -- default_tys instead
944 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
947 thetas = classes `zip` repeat [default_ty]
949 -- See if any default works, and if so bind the type variable to it
950 -- If not, add an AmbigErr
951 recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
953 try_default default_tys `thenTc` \ chosen_default_ty ->
955 -- Bind the type variable and reduce the context, for real this time
956 tcInstType emptyTyVarEnv chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
957 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
958 reduceContext (text "disambig" <+> ppr dicts)
959 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
960 ASSERT( null frees && null ambigs )
963 | all isCcallishClass classes
964 = -- Default CCall stuff to (); we don't even both to check that () is an
965 -- instance of CCallable/CReturnable, because we know it is.
966 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
967 returnTc EmptyMonoBinds
969 | otherwise -- No defaults
970 = addAmbigErr dicts `thenNF_Tc_`
971 returnTc EmptyMonoBinds
974 try_me inst = ReduceMe CarryOn
975 tyvar = get_tv (head dicts) -- Should be non-empty
976 classes = map get_clas dicts
983 ToDo: for these error messages, should we note the location as coming
984 from the insts, or just whatever seems to be around in the monad just
988 genCantGenErr insts -- Can't generalise these Insts
989 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
990 nest 4 (pprInstsInFull insts)
994 = tcAddSrcLoc (instLoc (head dicts)) $
995 addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts,
996 nest 4 (pprInstsInFull dicts)])
998 addNoInstanceErr dict
999 = tcAddSrcLoc (instLoc dict) $
1000 tcAddErrCtxt (pprOrigin dict) $
1001 addErrTc (noDictInstanceErr clas tys)
1003 (clas, tys) = getDictClassTys dict
1005 noDictInstanceErr clas tys
1006 = ptext SLIT("No instance for:") <+> quotes (pprConstraint clas tys)
1009 = sep [ptext SLIT("When matching against a type signature with context"),
1010 nest 4 (quotes (pprInsts (bagToList lie)))