2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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 CmdLineOpts ( opt_MaxContextReductionDepth )
127 import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
128 import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
129 TcMonoBinds, TcDictBinds
133 import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
135 isDict, isStdClassTyVarDict, isMethodFor,
136 instToId, instBindingRequired, instCanBeGeneralised,
138 instLoc, getDictClassTys,
139 pprInst, zonkInst, tidyInst, tidyInsts,
140 Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
143 import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars )
144 import TcType ( TcType, TcTyVarSet, typeToTcType )
145 import TcUnify ( unifyTauTy )
147 import VarSet ( mkVarSet )
149 import Bag ( bagToList )
150 import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
151 import PrelInfo ( isNumericClass, isCreturnableClass )
153 import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
154 isTyVarTy, substFlexiTheta, splitSigmaTy,
157 import PprType ( pprConstraint )
158 import TysWiredIn ( unitTy )
160 import VarEnv ( zipVarEnv )
162 import BasicTypes ( TopLevelFlag(..) )
163 import CmdLineOpts ( opt_GlasgowExts )
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 | isEmptyVarSet local_tvs
196 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
199 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
201 -- Check for non-generalisable insts
203 cant_generalise = filter (not . instCanBeGeneralised) irreds
205 checkTc (null cant_generalise)
206 (genCantGenErr cant_generalise) `thenTc_`
208 -- Check for ambiguous insts.
209 -- You might think these can't happen (I did) because an ambiguous
210 -- inst like (Eq a) will get tossed out with "frees", and eventually
211 -- dealt with by tcSimplifyTop.
212 -- But we can get stuck with
214 -- where "a" is one of the local_tvs, but "b" is unconstrained.
215 -- Then we must yell about the ambiguous b
216 -- But we must only do so if "b" really is unconstrained; so
217 -- we must grab the global tyvars to answer that question
218 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
220 avail_tvs = local_tvs `unionVarSet` global_tvs
221 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
222 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
224 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
228 returnTc (mkLIE frees, binds, mkLIE irreds')
230 wanteds = bagToList wanted_lie
233 -- Does not constrain a local tyvar
234 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
235 = -- if is_top_level then
236 -- FreeIfTautological -- Special case for inference on
237 -- -- top-level defns
241 -- We're infering (not checking) the type, and
242 -- the inst constrains a local type variable
243 | isDict inst = DontReduce -- Dicts
244 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
247 @tcSimplifyAndCheck@ is similar to the above, except that it checks
248 that there is an empty wanted-set at the end. It may still return
249 some of constant insts, which have to be resolved finally at the end.
254 -> TcTyVarSet s -- ``Local'' type variables
255 -- ASSERT: this tyvar set is already zonked
256 -> LIE s -- Given; constrain only local tyvars
258 -> TcM s (LIE s, -- Free
259 TcDictBinds s) -- Bindings
261 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
262 | isEmptyVarSet local_tvs
263 -- This can happen quite legitimately; for example in
264 -- instance Num Int where ...
265 = returnTc (wanted_lie, EmptyMonoBinds)
268 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
270 -- Complain about any irreducible ones
271 mapNF_Tc complain irreds `thenNF_Tc_`
274 returnTc (mkLIE frees, binds)
276 givens = bagToList given_lie
277 wanteds = bagToList wanted_lie
280 -- Does not constrain a local tyvar
281 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
284 -- When checking against a given signature we always reduce
285 -- until we find a match against something given, or can't reduce
287 = ReduceMe AddToIrreds
289 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
290 addNoInstanceErr str givens dict
294 %************************************************************************
296 \subsection{Data types for the reduction mechanism}
298 %************************************************************************
300 The main control over context reduction is here
304 = ReduceMe -- Try to reduce this
305 NoInstanceAction -- What to do if there's no such instance
307 | DontReduce -- Return as irreducible
309 | Free -- Return as free
311 | FreeIfTautological -- Return as free iff it's tautological;
312 -- if not, return as irreducible
314 data NoInstanceAction
315 = Stop -- Fail; no error message
316 -- (Only used when tautology checking.)
318 | AddToIrreds -- Just add the inst to the irreductible ones; don't
319 -- produce an error message of any kind.
320 -- It might be quite legitimate such as (Eq a)!
327 = (Avails s, -- What's available
328 [Inst s], -- Insts for which try_me returned Free
329 [Inst s] -- Insts for which try_me returned DontReduce
332 type Avails s = FiniteMap (Inst s) (Avail s)
336 (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that
337 -- caused this avail to be put into the finite map in the first place
338 -- It is this Id that is bound to the RHS.
340 (RHS s) -- The RHS: an expression whose value is that Inst.
341 -- The main Id should be bound to this RHS
343 [TcIdOcc s] -- Extra Ids that must all be bound to the main Id.
344 -- At the end we generate a list of bindings
345 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
348 = NoRhs -- Used for irreducible dictionaries,
349 -- which are going to be lambda bound, or for those that are
350 -- suppplied as "given" when checking againgst a signature.
352 -- NoRhs is also used for Insts like (CCallable f)
353 -- where no witness is required.
355 | Rhs -- Used when there is a RHS
357 Bool -- True => the RHS simply selects a superclass dictionary
358 -- from a subclass dictionary.
360 -- This is useful info, because superclass selection
361 -- is cheaper than building the dictionary using its dfun,
362 -- and we can sometimes replace the latter with the former
364 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
365 -- an (Ord t) dictionary; then we put an (Eq t) entry in
366 -- the finite map, with an PassiveScSel. Then if the
367 -- the (Eq t) binding is ever *needed* we make it an Rhs
369 [Inst s] -- List of Insts that are free in the RHS.
370 -- If the main Id is subsequently needed, we toss this list into
371 -- the needed-inst pool so that we make sure their bindings
372 -- will actually be produced.
374 -- Invariant: these Insts are already in the finite mapping
377 pprAvails avails = vcat (map pp (eltsFM avails))
379 pp (Avail main_id rhs ids)
380 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
382 pprRhs NoRhs = text "<no rhs>"
383 pprRhs (Rhs rhs b) = ppr rhs
384 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
388 %************************************************************************
390 \subsection[reduce]{@reduce@}
392 %************************************************************************
394 The main entry point for context reduction is @reduceContext@:
397 reduceContext :: SDoc -> (Inst s -> WhatToDo)
399 -> [Inst s] -- Wanted
400 -> TcM s (TcDictBinds s,
402 [Inst s]) -- Irreducible
404 reduceContext str try_me givens wanteds
406 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
407 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
410 pprTrace "reduceContext" (vcat [
411 text "----------------------",
413 text "given" <+> ppr givens,
414 text "wanted" <+> ppr wanteds,
415 text "----------------------"
418 -- Build the Avail mapping from "givens"
419 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
422 reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
424 -- Extract the bindings from avails
426 binds = foldFM add_bind EmptyMonoBinds avails
428 add_bind _ (Avail main_id rhs ids) binds
429 = foldr add_synonym (add_rhs_bind rhs binds) ids
431 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
432 add_rhs_bind other binds = binds
434 -- Add the trivial {x = y} bindings
435 -- The main Id can end up in the list when it's first added passively
436 -- and then activated, so we have to filter it out. A bit of a hack.
438 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
442 pprTrace ("reduceContext end") (vcat [
443 text "----------------------",
445 text "given" <+> ppr givens,
446 text "wanted" <+> ppr wanteds,
448 text "avails" <+> pprAvails avails,
449 text "irreds" <+> ppr irreds,
450 text "----------------------"
453 returnTc (binds, frees, irreds)
456 The main context-reduction function is @reduce@. Here's its game plan.
459 reduceList :: (Int,[Inst s])
460 -> (Inst s -> WhatToDo)
463 -> TcM s (RedState s)
467 try_me: given an inst, this function returns
469 DontReduce return this in "irreds"
470 Free return this in "frees"
472 wanteds: The list of insts to reduce
473 state: An accumulating parameter of type RedState
474 that contains the state of the algorithm
476 It returns a RedState.
480 reduceList (n,stack) try_me wanteds state
481 | n > opt_MaxContextReductionDepth
482 = failWithTc (reduceDepthErr n stack)
488 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
493 go [] state = returnTc state
494 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
497 -- Base case: we're done!
498 reduce stack try_me wanted state@(avails, frees, irreds)
500 -- It's the same as an existing inst, or a superclass thereof
501 | wanted `elemFM` avails
502 = returnTc (activate avails wanted, frees, irreds)
504 -- It should be reduced
505 | case try_me_result of { ReduceMe _ -> True; _ -> False }
506 = lookupInst wanted `thenNF_Tc` \ lookup_result ->
508 case lookup_result of
509 GenInst wanteds' rhs -> use_instance wanteds' rhs
510 SimpleInst rhs -> use_instance [] rhs
512 NoInstance -> -- No such instance!
513 -- Decide what to do based on the no_instance_action requested
514 case no_instance_action of
515 Stop -> failTc -- Fail
516 AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds
518 -- It's free and this isn't a top-level binding, so just chuck it upstairs
519 | case try_me_result of { Free -> True; _ -> False }
520 = -- First, see if the inst can be reduced to a constant in one step
521 lookupInst wanted `thenNF_Tc` \ lookup_result ->
522 case lookup_result of
523 SimpleInst rhs -> use_instance [] rhs
524 other -> add_to_frees
526 -- It's free and this is a top level binding, so
527 -- check whether it's a tautology or not
528 | case try_me_result of { FreeIfTautological -> True; _ -> False }
529 = -- Try for tautology
531 -- If tautology trial fails, add to irreds
532 (addGiven avails wanted `thenNF_Tc` \ avails' ->
533 returnTc (avails', frees, wanted:irreds))
535 -- If tautology succeeds, just add to frees
536 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
537 returnTc (avails, wanted:frees, irreds))
540 -- It's irreducible (or at least should not be reduced)
542 = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
543 -- See if the inst can be reduced to a constant in one step
544 lookupInst wanted `thenNF_Tc` \ lookup_result ->
545 case lookup_result of
546 SimpleInst rhs -> use_instance [] rhs
547 other -> add_to_irreds
550 -- The three main actions
552 avails' = addFree avails wanted
553 -- Add the thing to the avails set so any identical Insts
554 -- will be commoned up with it right here
556 returnTc (avails', wanted:frees, irreds)
558 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
559 returnTc (avails', frees, wanted:irreds)
561 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
562 reduceList stack try_me wanteds' (avails', frees, irreds)
564 try_me_result = try_me wanted
565 ReduceMe no_instance_action = try_me_result
567 -- The try-me to use when trying to identify tautologies
568 -- It blunders on reducing as much as possible
569 try_me_taut inst = ReduceMe Stop -- No error recovery
574 activate :: Avails s -> Inst s -> Avails s
575 -- Activate the binding for Inst, ensuring that a binding for the
576 -- wanted Inst will be generated.
577 -- (Activate its parent if necessary, recursively).
578 -- Precondition: the Inst is in Avails already
580 activate avails wanted
581 | not (instBindingRequired wanted)
585 = case lookupFM avails wanted of
587 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
588 foldl activate avails' insts -- Activate anything it needs
590 avails' = addToFM avails wanted avail'
591 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
593 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
594 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
596 Nothing -> panic "activate"
598 wanted_id = instToId wanted
600 addWanted avails wanted rhs_expr
601 = ASSERT( not (wanted `elemFM` avails) )
602 returnNF_Tc (addToFM avails wanted avail)
603 -- NB: we don't add the thing's superclasses too!
604 -- Why not? Because addWanted is used when we've successfully used an
605 -- instance decl to reduce something; e.g.
606 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
607 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
608 -- If we put the superclasses of "d" in avails, then we might end up
609 -- expressing "d1" in terms of "d", which would be a disaster.
611 avail = Avail (instToId wanted) rhs []
613 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
616 addFree :: Avails s -> Inst s -> (Avails s)
617 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
618 -- to avails, so that any other equal Insts will be commoned up right
619 -- here rather than also being tossed upstairs.
621 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
624 addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
625 addGiven avails given
626 = -- ASSERT( not (given `elemFM` avails) )
627 -- This assertion isn't necessarily true. It's permitted
628 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
629 -- and when typechecking instance decls we generate redundant "givens" too.
630 addAvail avails given avail
632 avail = Avail (instToId given) NoRhs []
634 addAvail avails wanted avail
635 = addSuperClasses (addToFM avails wanted avail) wanted
637 addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
638 -- Add all the superclasses of the Inst to Avails
639 -- Invariant: the Inst is already in Avails.
641 addSuperClasses avails dict
645 | otherwise -- It is a dictionary
646 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
648 (clas, tys) = getDictClassTys dict
650 (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
651 sc_theta' = substFlexiTheta (zipVarEnv tyvars tys) sc_theta
653 add_sc avails ((super_clas, super_tys), sc_sel)
654 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
656 sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
660 case lookupFM avails super_dict of
662 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
663 -- Already there, but not as a superclass selector
664 -- No need to look at its superclasses; since it's there
665 -- already they must be already in avails
666 -- However, we must remember to activate the dictionary
667 -- from which it is (now) generated
668 returnNF_Tc (activate avails' dict)
670 avails' = addToFM avails super_dict avail
671 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
673 Just (Avail _ _ _) -> returnNF_Tc avails
674 -- Already there; no need to do anything
677 -- Not there at all, so add it, and its superclasses
678 addAvail avails super_dict avail
680 avail = Avail (instToId super_dict)
681 (PassiveScSel sc_sel_rhs [dict])
685 %************************************************************************
687 \subsection[simple]{@Simple@ versions}
689 %************************************************************************
691 Much simpler versions when there are no bindings to make!
693 @tcSimplifyThetas@ simplifies class-type constraints formed by
694 @deriving@ declarations and when specialising instances. We are
695 only interested in the simplified bunch of class/type constraints.
697 It simplifies to constraints of the form (C a b c) where
698 a,b,c are type variables. This is required for the context of
699 instance declarations.
702 tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
703 -> ThetaType -- Wanted
704 -> TcM s ThetaType -- Needed; of the form C a b c
705 -- where a,b,c are type variables
707 tcSimplifyThetas inst_mapper wanteds
708 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
710 -- Check that the returned dictionaries are of the form (C a b c)
711 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
712 isEmptyVarSet (tyVarsOfTypes tys)]
713 | otherwise = [ct | ct@(clas,tys) <- irreds,
714 not (all isTyVarTy tys)]
717 if null bad_guys then
720 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
724 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
725 used with \tr{default} declarations. We are only interested in
726 whether it worked or not.
729 tcSimplifyCheckThetas :: ThetaType -- Given
730 -> ThetaType -- Wanted
733 tcSimplifyCheckThetas givens wanteds
734 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
738 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
744 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
745 -- True => irreducible
746 -- False => given, or can be derived from a given or from an irreducible
748 reduceSimple :: (Class -> ClassInstEnv)
749 -> ThetaType -- Given
750 -> ThetaType -- Wanted
751 -> NF_TcM s ThetaType -- Irreducible
753 reduceSimple inst_mapper givens wanteds
754 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
755 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
757 givens_fm = foldl addNonIrred emptyFM givens
759 reduce_simple :: (Int,ThetaType) -- Stack
760 -> (Class -> ClassInstEnv)
763 -> NF_TcM s AvailsSimple
765 reduce_simple (n,stack) inst_mapper avails wanteds
768 go avails [] = returnNF_Tc avails
769 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
772 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
773 | wanted `elemFM` givens
777 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
780 Nothing -> returnNF_Tc (addIrred givens wanted)
781 Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
783 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
785 = addSCs (addToFM givens ct True) ct
787 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
788 addNonIrred givens ct
789 = addSCs (addToFM givens ct False) ct
791 addSCs givens ct@(clas,tys)
792 = foldl add givens sc_theta
794 (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
795 sc_theta = substFlexiTheta (zipVarEnv tyvars tys) sc_theta_tmpl
797 add givens ct = case lookupFM givens ct of
798 Nothing -> -- Add it and its superclasses
799 addSCs (addToFM givens ct False) ct
801 Just True -> -- Set its flag to False; superclasses already done
802 addToFM givens ct False
804 Just False -> -- Already done
809 %************************************************************************
811 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
813 %************************************************************************
815 When doing a binding group, we may have @Insts@ of local functions.
816 For example, we might have...
818 let f x = x + 1 -- orig local function (overloaded)
819 f.1 = f Int -- two instances of f
824 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
825 where @f@ is in scope; those @Insts@ must certainly not be passed
826 upwards towards the top-level. If the @Insts@ were binding-ified up
827 there, they would have unresolvable references to @f@.
829 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
830 For each method @Inst@ in the @init_lie@ that mentions one of the
831 @Ids@, we create a binding. We return the remaining @Insts@ (in an
832 @LIE@), as well as the @HsBinds@ generated.
835 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
837 bindInstsOfLocalFuns init_lie local_ids
838 | null overloaded_ids || null lie_for_here
840 = returnTc (init_lie, EmptyMonoBinds)
843 = reduceContext (text "bindInsts" <+> ppr local_ids)
844 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
845 ASSERT( null irreds )
846 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
848 overloaded_ids = filter is_overloaded local_ids
849 is_overloaded id = case splitSigmaTy (idType id) of
850 (_, theta, _) -> not (null theta)
852 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
853 -- so it's worth building a set, so that
854 -- lookup (in isMethodFor) is faster
856 -- No sense in repeatedly zonking lots of
857 -- constant constraints so filter them out here
858 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
860 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
865 %************************************************************************
867 \section[Disambig]{Disambiguation of overloading}
869 %************************************************************************
872 If a dictionary constrains a type variable which is
875 not mentioned in the environment
877 and not mentioned in the type of the expression
879 then it is ambiguous. No further information will arise to instantiate
880 the type variable; nor will it be generalised and turned into an extra
881 parameter to a function.
883 It is an error for this to occur, except that Haskell provided for
884 certain rules to be applied in the special case of numeric types.
889 at least one of its classes is a numeric class, and
891 all of its classes are numeric or standard
893 then the type variable can be defaulted to the first type in the
894 default-type list which is an instance of all the offending classes.
896 So here is the function which does the work. It takes the ambiguous
897 dictionaries and either resolves them (producing bindings) or
898 complains. It works by splitting the dictionary list by type
899 variable, and using @disambigOne@ to do the real business.
902 @tcSimplifyTop@ is called once per module to simplify
903 all the constant and ambiguous Insts.
906 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
907 tcSimplifyTop wanted_lie
908 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
912 -- All the non-std ones are definite errors
913 (stds, non_stds) = partition isStdClassTyVarDict irreds
916 -- Group by type variable
917 std_groups = equivClasses cmp_by_tyvar stds
919 -- Pick the ones which its worth trying to disambiguate
920 (std_oks, std_bads) = partition worth_a_try std_groups
921 -- Have a try at disambiguation
922 -- if the type variable isn't bound
923 -- up with one of the non-standard classes
924 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
925 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
927 -- Collect together all the bad guys
928 bad_guys = non_stds ++ concat std_bads
931 -- Disambiguate the ones that look feasible
932 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
934 -- And complain about the ones that don't
935 mapNF_Tc complain bad_guys `thenNF_Tc_`
937 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
939 wanteds = bagToList wanted_lie
940 try_me inst = ReduceMe AddToIrreds
942 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
944 complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
945 | otherwise = addAmbigErr tyVarsOfInst d
947 get_tv d = case getDictClassTys d of
948 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
949 get_clas d = case getDictClassTys d of
953 @disambigOne@ assumes that its arguments dictionaries constrain all
954 the same type variable.
956 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
957 @()@ instead of @Int@. I reckon this is the Right Thing to do since
958 the most common use of defaulting is code like:
960 _ccall_ foo `seqPrimIO` bar
962 Since we're not using the result of @foo@, the result if (presumably)
966 disambigGroup :: [Inst s] -- All standard classes of form (C a)
967 -> TcM s (TcDictBinds s)
970 | any isNumericClass classes -- Guaranteed all standard classes
971 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
972 -- SO, TRY DEFAULT TYPES IN ORDER
974 -- Failure here is caused by there being no type in the
975 -- default list which can satisfy all the ambiguous classes.
976 -- For example, if Real a is reqd, but the only type in the
977 -- default list is Int.
978 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
980 try_default [] -- No defaults work, so fail
983 try_default (default_ty : default_tys)
984 = tryTc (try_default default_tys) $ -- If default_ty fails, we try
985 -- default_tys instead
986 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
989 thetas = classes `zip` repeat [default_ty]
991 -- See if any default works, and if so bind the type variable to it
992 -- If not, add an AmbigErr
993 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
995 try_default default_tys `thenTc` \ chosen_default_ty ->
997 -- Bind the type variable and reduce the context, for real this time
999 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1001 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1002 reduceContext (text "disambig" <+> ppr dicts)
1003 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1004 ASSERT( null frees && null ambigs )
1007 | all isCreturnableClass classes
1008 = -- Default CCall stuff to (); we don't even both to check that () is an
1009 -- instance of CReturnable, because we know it is.
1010 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1011 returnTc EmptyMonoBinds
1013 | otherwise -- No defaults
1014 = complain dicts `thenNF_Tc_`
1015 returnTc EmptyMonoBinds
1018 complain = addAmbigErrs tyVarsOfInst
1019 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1020 tyvar = get_tv (head dicts) -- Should be non-empty
1021 classes = map get_clas dicts
1028 ToDo: for these error messages, should we note the location as coming
1029 from the insts, or just whatever seems to be around in the monad just
1033 genCantGenErr insts -- Can't generalise these Insts
1034 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1035 nest 4 (pprInstsInFull insts)
1038 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1040 addAmbigErr ambig_tv_fn dict
1041 = tcAddSrcLoc (instLoc dict) $
1042 addErrTcM (tidy_env,
1043 sep [text "Ambiguous type variable(s)" <+>
1044 hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1045 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
1046 nest 4 (pprOrigin dict)])
1048 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1049 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1051 -- Used for top-level irreducibles
1052 addTopInstanceErr dict
1053 = tcAddSrcLoc (instLoc dict) $
1054 addErrTcM (tidy_env,
1055 sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
1056 nest 4 $ pprOrigin dict])
1058 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1060 addNoInstanceErr str givens dict
1061 = tcAddSrcLoc (instLoc dict) $
1062 addErrTcM (tidy_env,
1063 sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1064 nest 4 $ parens $ pprOrigin dict],
1065 nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens]
1067 ptext SLIT("Probable cause:") <+>
1068 vcat [ptext SLIT("missing") <+> quotes (pprInst tidy_dict) <+> ptext SLIT("in") <+> str,
1069 if all_tyvars then empty else
1070 ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1073 all_tyvars = all isTyVarTy tys
1074 (_, tys) = getDictClassTys dict
1075 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1077 -- Used for the ...Thetas variants; all top level
1079 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1081 reduceDepthErr n stack
1082 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1083 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1084 nest 4 (pprInstsInFull stack)]
1086 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)