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, opt_GlasgowExts )
127 import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
128 import TcHsSyn ( TcExpr, TcId,
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 ( 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, isCcallishClass )
153 import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
154 isTyVarTy, substTopTheta, splitSigmaTy, tyVarsOfTypes
156 import PprType ( pprConstraint )
157 import TysWiredIn ( unitTy )
159 import VarEnv ( zipVarEnv )
161 import BasicTypes ( TopLevelFlag(..) )
162 import CmdLineOpts ( opt_GlasgowExts )
165 import List ( partition )
169 %************************************************************************
171 \subsection[tcSimplify-main]{Main entry function}
173 %************************************************************************
175 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
176 the ``don't-squash-consts'' flag set depending on top-level ness. For
177 top level defns we *do* squash constants, so that they stay local to a
178 single defn. This makes things which are inlined more likely to be
179 exportable, because their constants are "inside". Later passes will
180 float them out if poss, after inlinings are sorted out.
186 -> TcTyVarSet -- ``Local'' type variables
187 -- ASSERT: this tyvar set is already zonked
189 -> TcM s (LIE, -- Free
190 TcDictBinds, -- Bindings
191 LIE) -- Remaining wanteds; no dups
193 tcSimplify str top_lvl local_tvs wanted_lie
194 | isEmptyVarSet local_tvs
195 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
198 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
200 -- Check for non-generalisable insts
202 cant_generalise = filter (not . instCanBeGeneralised) irreds
204 checkTc (null cant_generalise)
205 (genCantGenErr cant_generalise) `thenTc_`
207 -- Check for ambiguous insts.
208 -- You might think these can't happen (I did) because an ambiguous
209 -- inst like (Eq a) will get tossed out with "frees", and eventually
210 -- dealt with by tcSimplifyTop.
211 -- But we can get stuck with
213 -- where "a" is one of the local_tvs, but "b" is unconstrained.
214 -- Then we must yell about the ambiguous b
215 -- But we must only do so if "b" really is unconstrained; so
216 -- we must grab the global tyvars to answer that question
217 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
219 avail_tvs = local_tvs `unionVarSet` global_tvs
220 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
221 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
223 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
227 returnTc (mkLIE frees, binds, mkLIE irreds')
229 wanteds = bagToList wanted_lie
232 -- Does not constrain a local tyvar
233 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
234 = -- if is_top_level then
235 -- FreeIfTautological -- Special case for inference on
236 -- -- top-level defns
240 -- We're infering (not checking) the type, and
241 -- the inst constrains a local type variable
242 | isDict inst = DontReduce -- Dicts
243 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
246 @tcSimplifyAndCheck@ is similar to the above, except that it checks
247 that there is an empty wanted-set at the end. It may still return
248 some of constant insts, which have to be resolved finally at the end.
253 -> TcTyVarSet -- ``Local'' type variables
254 -- ASSERT: this tyvar set is already zonked
255 -> LIE -- Given; constrain only local tyvars
257 -> TcM s (LIE, -- Free
258 TcDictBinds) -- Bindings
260 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
261 | isEmptyVarSet local_tvs
262 -- This can happen quite legitimately; for example in
263 -- instance Num Int where ...
264 = returnTc (wanted_lie, EmptyMonoBinds)
267 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
269 -- Complain about any irreducible ones
270 mapNF_Tc complain irreds `thenNF_Tc_`
273 returnTc (mkLIE frees, binds)
275 givens = bagToList given_lie
276 wanteds = bagToList wanted_lie
277 given_dicts = filter isDict givens
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 given_dicts 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
313 -- The FreeIfTautological case is to allow the possibility
314 -- of generating functions with types like
315 -- f :: C Int => Int -> Int
316 -- Here, the C Int isn't a tautology presumably because Int
317 -- isn't an instance of C in this module; but perhaps it will
318 -- be at f's call site(s). Haskell doesn't allow this at
321 data NoInstanceAction
322 = Stop -- Fail; no error message
323 -- (Only used when tautology checking.)
325 | AddToIrreds -- Just add the inst to the irreductible ones; don't
326 -- produce an error message of any kind.
327 -- It might be quite legitimate such as (Eq a)!
334 = (Avails s, -- What's available
335 [Inst], -- Insts for which try_me returned Free
336 [Inst] -- Insts for which try_me returned DontReduce
339 type Avails s = FiniteMap Inst Avail
343 TcId -- The "main Id"; that is, the Id for the Inst that
344 -- caused this avail to be put into the finite map in the first place
345 -- It is this Id that is bound to the RHS.
347 RHS -- The RHS: an expression whose value is that Inst.
348 -- The main Id should be bound to this RHS
350 [TcId] -- Extra Ids that must all be bound to the main Id.
351 -- At the end we generate a list of bindings
352 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
355 = NoRhs -- Used for irreducible dictionaries,
356 -- which are going to be lambda bound, or for those that are
357 -- suppplied as "given" when checking againgst a signature.
359 -- NoRhs is also used for Insts like (CCallable f)
360 -- where no witness is required.
362 | Rhs -- Used when there is a RHS
364 Bool -- True => the RHS simply selects a superclass dictionary
365 -- from a subclass dictionary.
367 -- This is useful info, because superclass selection
368 -- is cheaper than building the dictionary using its dfun,
369 -- and we can sometimes replace the latter with the former
371 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
372 -- an (Ord t) dictionary; then we put an (Eq t) entry in
373 -- the finite map, with an PassiveScSel. Then if the
374 -- the (Eq t) binding is ever *needed* we make it an Rhs
376 [Inst] -- List of Insts that are free in the RHS.
377 -- If the main Id is subsequently needed, we toss this list into
378 -- the needed-inst pool so that we make sure their bindings
379 -- will actually be produced.
381 -- Invariant: these Insts are already in the finite mapping
384 pprAvails avails = vcat (map pp (eltsFM avails))
386 pp (Avail main_id rhs ids)
387 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
389 pprRhs NoRhs = text "<no rhs>"
390 pprRhs (Rhs rhs b) = ppr rhs
391 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
395 %************************************************************************
397 \subsection[reduce]{@reduce@}
399 %************************************************************************
401 The main entry point for context reduction is @reduceContext@:
404 reduceContext :: SDoc -> (Inst -> WhatToDo)
407 -> TcM s (TcDictBinds,
409 [Inst]) -- Irreducible
411 reduceContext str try_me givens wanteds
413 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
414 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
417 pprTrace "reduceContext" (vcat [
418 text "----------------------",
420 text "given" <+> ppr givens,
421 text "wanted" <+> ppr wanteds,
422 text "----------------------"
425 -- Build the Avail mapping from "givens"
426 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
429 reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
431 -- Extract the bindings from avails
433 binds = foldFM add_bind EmptyMonoBinds avails
435 add_bind _ (Avail main_id rhs ids) binds
436 = foldr add_synonym (add_rhs_bind rhs binds) ids
438 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
439 add_rhs_bind other binds = binds
441 -- Add the trivial {x = y} bindings
442 -- The main Id can end up in the list when it's first added passively
443 -- and then activated, so we have to filter it out. A bit of a hack.
445 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
449 pprTrace ("reduceContext end") (vcat [
450 text "----------------------",
452 text "given" <+> ppr givens,
453 text "wanted" <+> ppr wanteds,
455 text "avails" <+> pprAvails avails,
456 text "irreds" <+> ppr irreds,
457 text "----------------------"
460 returnTc (binds, frees, irreds)
463 The main context-reduction function is @reduce@. Here's its game plan.
466 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
467 -- along with its depth
468 -> (Inst -> WhatToDo)
471 -> TcM s (RedState s)
475 try_me: given an inst, this function returns
477 DontReduce return this in "irreds"
478 Free return this in "frees"
480 wanteds: The list of insts to reduce
481 state: An accumulating parameter of type RedState
482 that contains the state of the algorithm
484 It returns a RedState.
486 The (n,stack) pair is just used for error reporting.
487 n is always the depth of the stack.
488 The stack is the stack of Insts being reduced: to produce X
489 I had to produce Y, to produce Y I had to produce Z, and so on.
492 reduceList (n,stack) try_me wanteds state
493 | n > opt_MaxContextReductionDepth
494 = failWithTc (reduceDepthErr n stack)
500 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
505 go [] state = returnTc state
506 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
509 -- Base case: we're done!
510 reduce stack try_me wanted state@(avails, frees, irreds)
511 -- It's the same as an existing inst, or a superclass thereof
512 | wanted `elemFM` avails
513 = returnTc (activate avails wanted, frees, irreds)
516 = case try_me wanted of {
518 ReduceMe no_instance_action -> -- It should be reduced
519 lookupInst wanted `thenNF_Tc` \ lookup_result ->
520 case lookup_result of
521 GenInst wanteds' rhs -> use_instance wanteds' rhs
522 SimpleInst rhs -> use_instance [] rhs
524 NoInstance -> -- No such instance!
525 case no_instance_action of
527 AddToIrreds -> add_to_irreds
529 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
530 -- First, see if the inst can be reduced to a constant in one step
531 lookupInst wanted `thenNF_Tc` \ lookup_result ->
532 case lookup_result of
533 SimpleInst rhs -> use_instance [] rhs
534 other -> add_to_frees
539 FreeIfTautological -> -- It's free and this is a top level binding, so
540 -- check whether it's a tautology or not
542 add_to_irreds -- If tautology trial fails, add to irreds
544 -- If tautology succeeds, just add to frees
545 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
546 returnTc (avails, wanted:frees, irreds))
550 DontReduce -> -- It's irreducible (or at least should not be reduced)
551 -- See if the inst can be reduced to a constant in one step
552 lookupInst wanted `thenNF_Tc` \ lookup_result ->
553 case lookup_result of
554 SimpleInst rhs -> use_instance [] rhs
555 other -> add_to_irreds
558 -- The three main actions
560 avails' = addFree avails wanted
561 -- Add the thing to the avails set so any identical Insts
562 -- will be commoned up with it right here
564 returnTc (avails', wanted:frees, irreds)
566 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
567 returnTc (avails', frees, wanted:irreds)
569 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
570 reduceList stack try_me wanteds' (avails', frees, irreds)
573 -- The try-me to use when trying to identify tautologies
574 -- It blunders on reducing as much as possible
575 try_me_taut inst = ReduceMe Stop -- No error recovery
580 activate :: Avails s -> Inst -> Avails s
581 -- Activate the binding for Inst, ensuring that a binding for the
582 -- wanted Inst will be generated.
583 -- (Activate its parent if necessary, recursively).
584 -- Precondition: the Inst is in Avails already
586 activate avails wanted
587 | not (instBindingRequired wanted)
591 = case lookupFM avails wanted of
593 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
594 foldl activate avails' insts -- Activate anything it needs
596 avails' = addToFM avails wanted avail'
597 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
599 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
600 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
602 Nothing -> panic "activate"
604 wanted_id = instToId wanted
606 addWanted avails wanted rhs_expr
607 = ASSERT( not (wanted `elemFM` avails) )
608 returnNF_Tc (addToFM avails wanted avail)
609 -- NB: we don't add the thing's superclasses too!
610 -- Why not? Because addWanted is used when we've successfully used an
611 -- instance decl to reduce something; e.g.
612 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
613 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
614 -- If we put the superclasses of "d" in avails, then we might end up
615 -- expressing "d1" in terms of "d", which would be a disaster.
617 avail = Avail (instToId wanted) rhs []
619 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
622 addFree :: Avails s -> Inst -> (Avails s)
623 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
624 -- to avails, so that any other equal Insts will be commoned up right
625 -- here rather than also being tossed upstairs. This is really just
626 -- an optimisation, and perhaps it is more trouble that it is worth,
627 -- as the following comments show!
629 -- NB1: do *not* add superclasses. If we have
632 -- but a is not bound here, then we *don't* want to derive
633 -- dn from df here lest we lose sharing.
635 -- NB2: do *not* add the Inst to avails at all if it's a method.
636 -- The following situation shows why this is bad:
637 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
638 -- From an application (truncate f i) we get
639 -- t1 = truncate at f
641 -- If we have also have a secon occurrence of truncate, we get
642 -- t3 = truncate at f
644 -- When simplifying with i,f free, we might still notice that
645 -- t1=t3; but alas, the binding for t2 (which mentions t1)
646 -- will continue to float out!
647 -- Solution: never put methods in avail till they are captured
648 -- in which case addFree isn't used
650 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
653 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
654 addGiven avails given
655 = -- ASSERT( not (given `elemFM` avails) )
656 -- This assertion isn't necessarily true. It's permitted
657 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
658 -- and when typechecking instance decls we generate redundant "givens" too.
659 addAvail avails given avail
661 avail = Avail (instToId given) NoRhs []
663 addAvail avails wanted avail
664 = addSuperClasses (addToFM avails wanted avail) wanted
666 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
667 -- Add all the superclasses of the Inst to Avails
668 -- Invariant: the Inst is already in Avails.
670 addSuperClasses avails dict
674 | otherwise -- It is a dictionary
675 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
677 (clas, tys) = getDictClassTys dict
679 (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
680 sc_theta' = substTopTheta (zipVarEnv tyvars tys) sc_theta
682 add_sc avails ((super_clas, super_tys), sc_sel)
683 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
685 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
688 case lookupFM avails super_dict of
690 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
691 -- Already there, but not as a superclass selector
692 -- No need to look at its superclasses; since it's there
693 -- already they must be already in avails
694 -- However, we must remember to activate the dictionary
695 -- from which it is (now) generated
696 returnNF_Tc (activate avails' dict)
698 avails' = addToFM avails super_dict avail
699 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
701 Just (Avail _ _ _) -> returnNF_Tc avails
702 -- Already there; no need to do anything
705 -- Not there at all, so add it, and its superclasses
706 addAvail avails super_dict avail
708 avail = Avail (instToId super_dict)
709 (PassiveScSel sc_sel_rhs [dict])
713 %************************************************************************
715 \subsection[simple]{@Simple@ versions}
717 %************************************************************************
719 Much simpler versions when there are no bindings to make!
721 @tcSimplifyThetas@ simplifies class-type constraints formed by
722 @deriving@ declarations and when specialising instances. We are
723 only interested in the simplified bunch of class/type constraints.
725 It simplifies to constraints of the form (C a b c) where
726 a,b,c are type variables. This is required for the context of
727 instance declarations.
730 tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
731 -> ThetaType -- Wanted
732 -> TcM s ThetaType -- Needed
734 tcSimplifyThetas inst_mapper wanteds
735 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
737 -- For multi-param Haskell, check that the returned dictionaries
738 -- don't have any of the form (C Int Bool) for which
739 -- we expect an instance here
740 -- For Haskell 98, check that all the constraints are of the form C a,
741 -- where a is a type variable
742 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
743 isEmptyVarSet (tyVarsOfTypes tys)]
744 | otherwise = [ct | ct@(clas,tys) <- irreds,
745 not (all isTyVarTy tys)]
747 if null bad_guys then
750 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
754 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
755 used with \tr{default} declarations. We are only interested in
756 whether it worked or not.
759 tcSimplifyCheckThetas :: ThetaType -- Given
760 -> ThetaType -- Wanted
763 tcSimplifyCheckThetas givens wanteds
764 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
768 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
774 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
775 -- True => irreducible
776 -- False => given, or can be derived from a given or from an irreducible
778 reduceSimple :: (Class -> ClassInstEnv)
779 -> ThetaType -- Given
780 -> ThetaType -- Wanted
781 -> NF_TcM s ThetaType -- Irreducible
783 reduceSimple inst_mapper givens wanteds
784 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
785 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
787 givens_fm = foldl addNonIrred emptyFM givens
789 reduce_simple :: (Int,ThetaType) -- Stack
790 -> (Class -> ClassInstEnv)
793 -> NF_TcM s AvailsSimple
795 reduce_simple (n,stack) inst_mapper avails wanteds
798 go avails [] = returnNF_Tc avails
799 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
802 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
803 | wanted `elemFM` givens
807 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
810 Nothing -> returnNF_Tc (addIrred givens wanted)
811 Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
813 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
815 = addSCs (addToFM givens ct True) ct
817 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
818 addNonIrred givens ct
819 = addSCs (addToFM givens ct False) ct
821 addSCs givens ct@(clas,tys)
822 = foldl add givens sc_theta
824 (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
825 sc_theta = substTopTheta (zipVarEnv tyvars tys) sc_theta_tmpl
827 add givens ct = case lookupFM givens ct of
828 Nothing -> -- Add it and its superclasses
829 addSCs (addToFM givens ct False) ct
831 Just True -> -- Set its flag to False; superclasses already done
832 addToFM givens ct False
834 Just False -> -- Already done
839 %************************************************************************
841 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
843 %************************************************************************
845 When doing a binding group, we may have @Insts@ of local functions.
846 For example, we might have...
848 let f x = x + 1 -- orig local function (overloaded)
849 f.1 = f Int -- two instances of f
854 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
855 where @f@ is in scope; those @Insts@ must certainly not be passed
856 upwards towards the top-level. If the @Insts@ were binding-ified up
857 there, they would have unresolvable references to @f@.
859 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
860 For each method @Inst@ in the @init_lie@ that mentions one of the
861 @Ids@, we create a binding. We return the remaining @Insts@ (in an
862 @LIE@), as well as the @HsBinds@ generated.
865 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
867 bindInstsOfLocalFuns init_lie local_ids
868 | null overloaded_ids || null lie_for_here
870 = returnTc (init_lie, EmptyMonoBinds)
873 = reduceContext (text "bindInsts" <+> ppr local_ids)
874 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
875 ASSERT( null irreds )
876 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
878 overloaded_ids = filter is_overloaded local_ids
879 is_overloaded id = case splitSigmaTy (idType id) of
880 (_, theta, _) -> not (null theta)
882 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
883 -- so it's worth building a set, so that
884 -- lookup (in isMethodFor) is faster
886 -- No sense in repeatedly zonking lots of
887 -- constant constraints so filter them out here
888 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
890 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
895 %************************************************************************
897 \section[Disambig]{Disambiguation of overloading}
899 %************************************************************************
902 If a dictionary constrains a type variable which is
905 not mentioned in the environment
907 and not mentioned in the type of the expression
909 then it is ambiguous. No further information will arise to instantiate
910 the type variable; nor will it be generalised and turned into an extra
911 parameter to a function.
913 It is an error for this to occur, except that Haskell provided for
914 certain rules to be applied in the special case of numeric types.
919 at least one of its classes is a numeric class, and
921 all of its classes are numeric or standard
923 then the type variable can be defaulted to the first type in the
924 default-type list which is an instance of all the offending classes.
926 So here is the function which does the work. It takes the ambiguous
927 dictionaries and either resolves them (producing bindings) or
928 complains. It works by splitting the dictionary list by type
929 variable, and using @disambigOne@ to do the real business.
932 @tcSimplifyTop@ is called once per module to simplify
933 all the constant and ambiguous Insts.
936 tcSimplifyTop :: LIE -> TcM s TcDictBinds
937 tcSimplifyTop wanted_lie
938 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
942 -- All the non-std ones are definite errors
943 (stds, non_stds) = partition isStdClassTyVarDict irreds
946 -- Group by type variable
947 std_groups = equivClasses cmp_by_tyvar stds
949 -- Pick the ones which its worth trying to disambiguate
950 (std_oks, std_bads) = partition worth_a_try std_groups
951 -- Have a try at disambiguation
952 -- if the type variable isn't bound
953 -- up with one of the non-standard classes
954 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
955 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
957 -- Collect together all the bad guys
958 bad_guys = non_stds ++ concat std_bads
961 -- Disambiguate the ones that look feasible
962 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
964 -- And complain about the ones that don't
965 mapNF_Tc complain bad_guys `thenNF_Tc_`
967 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
969 wanteds = bagToList wanted_lie
970 try_me inst = ReduceMe AddToIrreds
972 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
974 complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
975 | otherwise = addAmbigErr tyVarsOfInst d
977 get_tv d = case getDictClassTys d of
978 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
979 get_clas d = case getDictClassTys d of
983 @disambigOne@ assumes that its arguments dictionaries constrain all
984 the same type variable.
986 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
987 @()@ instead of @Int@. I reckon this is the Right Thing to do since
988 the most common use of defaulting is code like:
990 _ccall_ foo `seqPrimIO` bar
992 Since we're not using the result of @foo@, the result if (presumably)
996 disambigGroup :: [Inst] -- All standard classes of form (C a)
1000 | any isNumericClass classes -- Guaranteed all standard classes
1001 -- see comment at the end of function for reasons as to
1002 -- why the defaulting mechanism doesn't apply to groups that
1003 -- include CCallable or CReturnable dicts.
1004 && not (any isCcallishClass classes)
1005 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1006 -- SO, TRY DEFAULT TYPES IN ORDER
1008 -- Failure here is caused by there being no type in the
1009 -- default list which can satisfy all the ambiguous classes.
1010 -- For example, if Real a is reqd, but the only type in the
1011 -- default list is Int.
1012 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1014 try_default [] -- No defaults work, so fail
1017 try_default (default_ty : default_tys)
1018 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1019 -- default_tys instead
1020 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1023 thetas = classes `zip` repeat [default_ty]
1025 -- See if any default works, and if so bind the type variable to it
1026 -- If not, add an AmbigErr
1027 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1029 try_default default_tys `thenTc` \ chosen_default_ty ->
1031 -- Bind the type variable and reduce the context, for real this time
1033 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1035 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1036 reduceContext (text "disambig" <+> ppr dicts)
1037 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1038 ASSERT( null frees && null ambigs )
1041 | all isCreturnableClass classes
1042 = -- Default CCall stuff to (); we don't even both to check that () is an
1043 -- instance of CReturnable, because we know it is.
1044 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1045 returnTc EmptyMonoBinds
1047 | otherwise -- No defaults
1048 = complain dicts `thenNF_Tc_`
1049 returnTc EmptyMonoBinds
1052 complain = addAmbigErrs tyVarsOfInst
1053 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1054 tyvar = get_tv (head dicts) -- Should be non-empty
1055 classes = map get_clas dicts
1058 [Aside - why the defaulting mechanism is turned off when
1059 dealing with arguments and results to ccalls.
1061 When typechecking _ccall_s, TcExpr ensures that the external
1062 function is only passed arguments (and in the other direction,
1063 results) of a restricted set of 'native' types. This is
1064 implemented via the help of the pseudo-type classes,
1065 @CReturnable@ (CR) and @CCallable@ (CC.)
1067 The interaction between the defaulting mechanism for numeric
1068 values and CC & CR can be a bit puzzling to the user at times.
1077 What type has 'x' got here? That depends on the default list
1078 in operation, if it is equal to Haskell 98's default-default
1079 of (Integer, Double), 'x' has type Double, since Integer
1080 is not an instance of CR. If the default list is equal to
1081 Haskell 1.4's default-default of (Int, Double), 'x' has type
1084 To try to minimise the potential for surprises here, the
1085 defaulting mechanism is turned off in the presence of
1086 CCallable and CReturnable.
1092 ToDo: for these error messages, should we note the location as coming
1093 from the insts, or just whatever seems to be around in the monad just
1097 genCantGenErr insts -- Can't generalise these Insts
1098 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1099 nest 4 (pprInstsInFull insts)
1102 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1104 addAmbigErr ambig_tv_fn dict
1105 = tcAddSrcLoc (instLoc dict) $
1106 addErrTcM (tidy_env,
1107 sep [text "Ambiguous type variable(s)" <+>
1108 hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1109 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
1110 nest 4 (pprOrigin dict)])
1112 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1113 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1115 -- Used for top-level irreducibles
1116 addTopInstanceErr dict
1117 = tcAddSrcLoc (instLoc dict) $
1118 addErrTcM (tidy_env,
1119 sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
1120 nest 4 $ pprOrigin dict])
1122 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1124 addNoInstanceErr str givens dict
1125 = tcAddSrcLoc (instLoc dict) $
1126 addErrTcM (tidy_env,
1127 sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1128 nest 4 $ parens $ pprOrigin dict],
1129 nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1131 ptext SLIT("Probable cause:") <+>
1132 vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1133 ptext SLIT("in") <+> str],
1134 if all_tyvars then empty else
1135 ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1138 all_tyvars = all isTyVarTy tys
1139 (_, tys) = getDictClassTys dict
1140 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1142 -- Used for the ...Thetas variants; all top level
1144 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1146 reduceDepthErr n stack
1147 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1148 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1149 nest 4 (pprInstsInFull stack)]
1151 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)