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 isDict, isStdClassTyVarDict, isMethodFor,
135 instToId, instBindingRequired, instCanBeGeneralised,
137 instLoc, getDictClassTys,
139 Inst, LIE, pprInsts, pprInstsInFull, mkLIE,
140 InstOrigin, pprOrigin
142 import TcEnv ( TcIdOcc(..) )
143 import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
144 import Unify ( unifyTauTy )
145 import Id ( mkIdSet )
147 import Bag ( Bag, bagToList, snocBag )
148 import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
149 import PrelInfo ( isNumericClass, isCreturnableClass )
151 import Maybes ( maybeToBool )
152 import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
153 isTyVarTy, instantiateThetaTy
155 import PprType ( pprConstraint )
156 import TysWiredIn ( unitTy )
157 import TyVar ( intersectTyVarSets, unionManyTyVarSets, minusTyVarSet,
158 isEmptyTyVarSet, tyVarSetToList,
159 zipTyVarEnv, emptyTyVarEnv
162 import BasicTypes ( TopLevelFlag(..) )
163 import Unique ( Unique )
166 import List ( partition )
170 %************************************************************************
172 \subsection[tcSimplify-main]{Main entry function}
174 %************************************************************************
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.
187 -> TcTyVarSet s -- ``Local'' type variables
188 -- ASSERT: this tyvar set is already zonked
190 -> TcM s (LIE s, -- Free
191 TcDictBinds s, -- Bindings
192 LIE s) -- Remaining wanteds; no dups
194 tcSimplify str top_lvl local_tvs wanted_lie
195 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
197 -- Check for non-generalisable insts
199 cant_generalise = filter (not . instCanBeGeneralised) irreds
201 checkTc (null cant_generalise)
202 (genCantGenErr cant_generalise) `thenTc_`
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
210 -- where "a" is one of the local_tvs, but "b" is unconstrained.
211 -- Then we must yell about the ambiguous b
213 (irreds', bad_guys) = partition (isEmptyTyVarSet . ambig_tv_fn) irreds
214 ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` local_tvs
216 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
220 returnTc (mkLIE frees, binds, mkLIE irreds')
222 wanteds = bagToList wanted_lie
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
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
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.
246 -> TcTyVarSet s -- ``Local'' type variables
247 -- ASSERT: this tyvar set is already zonked
248 -> LIE s -- Given; constrain only local tyvars
250 -> TcM s (LIE s, -- Free
251 TcDictBinds s) -- Bindings
253 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
254 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
256 -- Complain about any irreducible ones
257 mapNF_Tc complain irreds `thenNF_Tc_`
260 returnTc (mkLIE frees, binds)
262 givens = bagToList given_lie
263 wanteds = bagToList wanted_lie
266 -- Does not constrain a local tyvar
267 | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
270 -- When checking against a given signature we always reduce
271 -- until we find a match against something given, or can't reduce
273 = ReduceMe AddToIrreds
275 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
276 addNoInstanceErr str givens dict
280 %************************************************************************
282 \subsection{Data types for the reduction mechanism}
284 %************************************************************************
286 The main control over context reduction is here
290 = ReduceMe -- Try to reduce this
291 NoInstanceAction -- What to do if there's no such instance
293 | DontReduce -- Return as irreducible
295 | Free -- Return as free
297 | FreeIfTautological -- Return as free iff it's tautological;
298 -- if not, return as irreducible
300 data NoInstanceAction
301 = Stop -- Fail; no error message
302 -- (Only used when tautology checking.)
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)!
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
318 type Avails s = FiniteMap (Inst s) (Avail s)
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.
326 (RHS s) -- The RHS: an expression whose value is that Inst.
327 -- The main Id should be bound to this RHS
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; ... }
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.
338 -- NoRhs is also used for Insts like (CCallable f)
339 -- where no witness is required.
341 | Rhs -- Used when there is a RHS
343 Bool -- True => the RHS simply selects a superclass dictionary
344 -- from a subclass dictionary.
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
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
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.
360 -- Invariant: these Insts are already in the finite mapping
363 pprAvails avails = vcat (map pp (eltsFM avails))
365 pp (Avail main_id rhs ids)
366 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
368 pprRhs NoRhs = text "<no rhs>"
369 pprRhs (Rhs rhs b) = ppr rhs
370 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
374 %************************************************************************
376 \subsection[reduce]{@reduce@}
378 %************************************************************************
380 The main entry point for context reduction is @reduceContext@:
383 reduceContext :: SDoc -> (Inst s -> WhatToDo)
385 -> [Inst s] -- Wanted
386 -> TcM s (TcDictBinds s,
388 [Inst s]) -- Irreducible
390 reduceContext str try_me givens wanteds
392 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
393 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
396 pprTrace "reduceContext" (vcat [
397 text "----------------------",
399 text "given" <+> ppr givens,
400 text "wanted" <+> ppr wanteds,
401 text "----------------------"
405 -- Build the Avail mapping from "givens"
406 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
409 reduce try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
411 -- Extract the bindings from avails
413 binds = foldFM add_bind EmptyMonoBinds avails
415 add_bind _ (Avail main_id rhs ids) binds
416 = foldr add_synonym (add_rhs_bind rhs binds) ids
418 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
419 add_rhs_bind other binds = binds
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.
425 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
429 pprTrace ("reduceContext1") (vcat [
430 text "----------------------",
432 text "given" <+> ppr givens,
433 text "wanted" <+> ppr wanteds,
436 text "----------------------"
439 returnTc (binds, frees, irreds)
442 The main context-reduction function is @reduce@. Here's its game plan.
445 reduce :: (Inst s -> WhatToDo)
448 -> TcM s (RedState s)
452 try_me: given an inst, this function returns
454 DontReduce return this in "irreds"
455 Free return this in "frees"
457 wanteds: The list of insts to reduce
458 state: An accumulating parameter of type RedState
459 that contains the state of the algorithm
461 It returns a RedState.
465 -- Base case: we're done!
466 reduce try_me [] state = returnTc state
468 reduce try_me (wanted:wanteds) state@(avails, frees, irreds)
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)
474 -- It should be reduced
475 | case try_me_result of { ReduceMe _ -> True; _ -> False }
476 = lookupInst wanted `thenNF_Tc` \ lookup_result ->
478 case lookup_result of
479 GenInst wanteds' rhs -> use_instance wanteds' rhs
480 SimpleInst rhs -> use_instance [] rhs
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
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
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
501 -- If tautology trial fails, add to irreds
502 (addGiven avails wanted `thenNF_Tc` \ avails' ->
503 returnTc (avails', frees, wanted:irreds))
505 -- If tautology succeeds, just add to frees
506 (reduce try_me_taut [wanted] (avails, [], []) `thenTc_`
507 returnTc (avails, wanted:frees, irreds))
509 reduce try_me wanteds state'
512 -- It's irreducible (or at least should not be reduced)
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
522 -- The three main actions
523 add_to_frees = reduce try_me wanteds (avails, wanted:frees, irreds)
525 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
526 reduce try_me wanteds (avails', frees, wanted:irreds)
528 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
529 reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds)
532 try_me_result = try_me wanted
533 ReduceMe no_instance_action = try_me_result
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
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
548 activate avails wanted
549 | not (instBindingRequired wanted)
553 = case lookupFM avails wanted of
555 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
556 foldl activate avails' insts -- Activate anything it needs
558 avails' = addToFM avails wanted avail'
559 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
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))
564 Nothing -> panic "activate"
566 wanted_id = instToId wanted
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.
579 avail = Avail (instToId wanted) rhs []
581 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
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
592 avail = Avail (instToId given) NoRhs []
594 addAvail avails wanted avail
595 = addSuperClasses (addToFM avails wanted avail) wanted
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.
601 addSuperClasses avails dict
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)
609 (clas, tys) = getDictClassTys dict
611 (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
612 env = zipTyVarEnv tyvars tys
614 add_sc avails ((super_clas, super_tys), sc_sel)
615 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
617 sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
621 case lookupFM avails super_dict of
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)
631 avails' = addToFM avails super_dict avail
632 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
634 Just (Avail _ _ _) -> returnNF_Tc avails
635 -- Already there; no need to do anything
638 -- Not there at all, so add it, and its superclasses
639 addAvail avails super_dict avail
641 avail = Avail (instToId super_dict)
642 (PassiveScSel sc_sel_rhs [dict])
646 %************************************************************************
648 \subsection[simple]{@Simple@ versions}
650 %************************************************************************
652 Much simpler versions when there are no bindings to make!
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.
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.
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
668 tcSimplifyThetas inst_mapper wanteds
669 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
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)]
674 if null bad_guys then
677 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
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.
686 tcSimplifyCheckThetas :: ThetaType -- Given
687 -> ThetaType -- Wanted
690 tcSimplifyCheckThetas givens wanteds
691 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
695 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
701 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
702 -- True => irreducible
703 -- False => given, or can be derived from a given or from an irreducible
705 reduceSimple :: (Class -> ClassInstEnv)
706 -> ThetaType -- Given
707 -> ThetaType -- Wanted
708 -> NF_TcM s ThetaType -- Irreducible
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']
714 givens_fm = foldl addNonIrred emptyFM givens
716 reduce_simple :: (Class -> ClassInstEnv)
719 -> NF_TcM s AvailsSimple
721 reduce_simple inst_mapper givens []
722 = -- Finished, so pull out the needed ones
725 reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds)
726 | wanted `elemFM` givens
727 = reduce_simple inst_mapper givens wanteds
730 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
733 Nothing -> reduce_simple inst_mapper (addIrred givens wanted) wanteds
734 Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds)
736 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
738 = addSCs (addToFM givens ct True) ct
740 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
741 addNonIrred givens ct
742 = addSCs (addToFM givens ct False) ct
744 addSCs givens ct@(clas,tys)
745 = foldl add givens sc_theta
747 (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
748 sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl
750 add givens ct = case lookupFM givens ct of
751 Nothing -> -- Add it and its superclasses
752 addSCs (addToFM givens ct False) ct
754 Just True -> -- Set its flag to False; superclasses already done
755 addToFM givens ct False
757 Just False -> -- Already done
762 %************************************************************************
764 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
766 %************************************************************************
768 When doing a binding group, we may have @Insts@ of local functions.
769 For example, we might have...
771 let f x = x + 1 -- orig local function (overloaded)
772 f.1 = f Int -- two instances of f
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@.
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.
788 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
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)
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
804 %************************************************************************
806 \section[Disambig]{Disambiguation of overloading}
808 %************************************************************************
811 If a dictionary constrains a type variable which is
814 not mentioned in the environment
816 and not mentioned in the type of the expression
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.
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.
828 at least one of its classes is a numeric class, and
830 all of its classes are numeric or standard
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.
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.
841 @tcSimplifyTop@ is called once per module to simplify
842 all the constant and ambiguous Insts.
845 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
846 tcSimplifyTop wanted_lie
847 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
851 -- All the non-std ones are definite errors
852 (stds, non_stds) = partition isStdClassTyVarDict irreds
855 -- Group by type variable
856 std_groups = equivClasses cmp_by_tyvar stds
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)
866 -- Collect together all the bad guys
867 bad_guys = non_stds ++ concat std_bads
870 -- Disambiguate the ones that look feasible
871 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
873 -- And complain about the ones that don't
874 mapNF_Tc complain bad_guys `thenNF_Tc_`
876 returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
878 wanteds = bagToList wanted_lie
879 try_me inst = ReduceMe AddToIrreds
881 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
883 complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d
884 | otherwise = addAmbigErr tyVarsOfInst d
886 get_tv d = case getDictClassTys d of
887 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
888 get_clas d = case getDictClassTys d of
892 @disambigOne@ assumes that its arguments dictionaries constrain all
893 the same type variable.
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:
899 _ccall_ foo `seqPrimIO` bar
901 Since we're not using the result of @foo@, the result if (presumably)
905 disambigGroup :: [Inst s] -- All standard classes of form (C a)
906 -> TcM s (TcDictBinds s)
909 | any isNumericClass classes -- Guaranteed all standard classes
910 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
911 -- SO, TRY DEFAULT TYPES IN ORDER
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 ->
919 try_default [] -- No defaults work, so fail
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` \ _ ->
928 thetas = classes `zip` repeat [default_ty]
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) $
934 try_default default_tys `thenTc` \ chosen_default_ty ->
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 )
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
950 | otherwise -- No defaults
951 = complain dicts `thenNF_Tc_`
952 returnTc EmptyMonoBinds
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
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
970 genCantGenErr insts -- Can't generalise these Insts
971 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
972 nest 4 (pprInstsInFull insts)
975 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
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)])
984 ambig_tvs = tyVarSetToList (ambig_tv_fn dict)
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])
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]
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)]
1004 all_tyvars = all isTyVarTy tys
1005 (_, tys) = getDictClassTys dict
1007 -- Used for the ...Thetas variants; all top level
1009 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))