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, tcSimplifyToDicts,
120 tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
121 bindInstsOfLocalFuns, partitionPredsOfLIE
124 #include "HsVersions.h"
126 import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
127 import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
128 import TcHsSyn ( TcExpr, TcId,
129 TcMonoBinds, TcDictBinds
133 import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
135 isDict, isClassDict, isMethod, notFunDep,
136 isStdClassTyVarDict, isMethodFor,
137 instToId, instBindingRequired, instCanBeGeneralised,
138 newDictFromOld, newFunDepFromDict,
139 getDictClassTys, getIPs, isTyVarDict,
140 getDictPred_maybe, getMethodTheta_maybe,
141 instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
142 Inst, LIE, pprInsts, pprInstsInFull,
143 mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
146 import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv,
147 lookupInstEnv, InstLookupResult(..)
149 import TcType ( TcTyVarSet )
150 import TcUnify ( unifyTauTy )
152 import Class ( Class, classBigSig )
153 import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
155 import Type ( Type, ClassContext,
157 isTyVarTy, splitSigmaTy, tyVarsOfTypes
159 import Subst ( mkTopTyVarSubst, substClasses )
160 import PprType ( pprConstraint )
161 import TysWiredIn ( unitTy )
164 import CmdLineOpts ( opt_GlasgowExts )
166 import ListSetOps ( equivClasses )
167 import Util ( zipEqual, mapAccumL )
168 import List ( partition )
169 import Maybe ( fromJust )
170 import Maybes ( maybeToBool )
174 %************************************************************************
176 \subsection[tcSimplify-main]{Main entry function}
178 %************************************************************************
180 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
181 the ``don't-squash-consts'' flag set depending on top-level ness. For
182 top level defns we *do* squash constants, so that they stay local to a
183 single defn. This makes things which are inlined more likely to be
184 exportable, because their constants are "inside". Later passes will
185 float them out if poss, after inlinings are sorted out.
190 -> TcTyVarSet -- ``Local'' type variables
191 -- ASSERT: this tyvar set is already zonked
194 TcDictBinds, -- Bindings
195 LIE) -- Remaining wanteds; no dups
197 tcSimplify str local_tvs wanted_lie
198 {- this is just an optimization, and interferes with implicit params,
199 disable it for now. same goes for tcSimplifyAndCheck
200 | isEmptyVarSet local_tvs
201 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
205 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
207 -- Check for non-generalisable insts
209 cant_generalise = filter (not . instCanBeGeneralised) irreds
211 checkTc (null cant_generalise)
212 (genCantGenErr cant_generalise) `thenTc_`
214 -- Check for ambiguous insts.
215 -- You might think these can't happen (I did) because an ambiguous
216 -- inst like (Eq a) will get tossed out with "frees", and eventually
217 -- dealt with by tcSimplifyTop.
218 -- But we can get stuck with
220 -- where "a" is one of the local_tvs, but "b" is unconstrained.
221 -- Then we must yell about the ambiguous b
222 -- But we must only do so if "b" really is unconstrained; so
223 -- we must grab the global tyvars to answer that question
224 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
226 avail_tvs = local_tvs `unionVarSet` global_tvs
227 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
228 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
230 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
234 returnTc (mkLIE frees, binds, mkLIE irreds')
236 wanteds = lieToList wanted_lie
239 -- Does not constrain a local tyvar
240 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
241 && null (getIPs inst)
242 = -- if is_top_level then
243 -- FreeIfTautological -- Special case for inference on
244 -- -- top-level defns
248 -- We're infering (not checking) the type, and
249 -- the inst constrains a local type variable
250 | isClassDict inst = DontReduceUnlessConstant -- Dicts
251 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
254 @tcSimplifyAndCheck@ is similar to the above, except that it checks
255 that there is an empty wanted-set at the end. It may still return
256 some of constant insts, which have to be resolved finally at the end.
261 -> TcTyVarSet -- ``Local'' type variables
262 -- ASSERT: this tyvar set is already zonked
263 -> LIE -- Given; constrain only local tyvars
266 TcDictBinds) -- Bindings
268 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
270 | isEmptyVarSet local_tvs
271 -- This can happen quite legitimately; for example in
272 -- instance Num Int where ...
273 = returnTc (wanted_lie, EmptyMonoBinds)
277 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
279 -- Complain about any irreducible ones
280 mapNF_Tc complain irreds `thenNF_Tc_`
283 returnTc (mkLIE frees, binds)
285 givens = lieToList given_lie
286 wanteds = lieToList wanted_lie
287 given_dicts = filter isClassDict givens
290 -- Does not constrain a local tyvar
291 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
292 && (not (isMethod inst) || null (getIPs inst))
295 -- When checking against a given signature we always reduce
296 -- until we find a match against something given, or can't reduce
298 = ReduceMe AddToIrreds
300 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
301 addNoInstanceErr str given_dicts dict
304 On the LHS of transformation rules we only simplify methods and constants,
305 getting dictionaries. We want to keep all of them unsimplified, to serve
306 as the available stuff for the RHS of the rule.
308 The same thing is used for specialise pragmas. Consider
311 {-# SPECIALISE f :: Int -> Int #-}
314 The type checker generates a binding like:
316 f_spec = (f :: Int -> Int)
318 and we want to end up with
320 f_spec = _inline_me_ (f Int dNumInt)
322 But that means that we must simplify the Method for f to (f Int dNumInt)!
323 So tcSimplifyToDicts squeezes out all Methods.
326 tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds)
327 tcSimplifyToDicts wanted_lie
328 = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
330 returnTc (mkLIE irreds, binds)
332 wanteds = lieToList wanted_lie
334 -- Reduce methods and lits only; stop as soon as we get a dictionary
335 try_me inst | isDict inst = DontReduce
336 | otherwise = ReduceMe AddToIrreds
339 The following function partitions a LIE by a predicate defined
340 over `Pred'icates (an unfortunate overloading of terminology!).
341 This means it sometimes has to split up `Methods', in which case
342 a binding is generated.
344 It is used in `with' bindings to extract from the LIE the implicit
345 parameters being bound.
348 partitionPredsOfLIE pred lie
349 = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
350 where insts = lieToList lie
352 -- warning: the term `pred' is overloaded here!
353 partPreds pred (lie1, lie2, binds) inst
354 | maybeToBool maybe_pred
356 returnTc (consLIE inst lie1, lie2, binds)
358 returnTc (lie1, consLIE inst lie2, binds)
359 where maybe_pred = getDictPred_maybe inst
362 -- the assumption is that those satisfying `pred' are being extracted,
363 -- so we leave the method untouched when nothing satisfies `pred'
364 partPreds pred (lie1, lie2, binds1) inst
365 | maybeToBool maybe_theta
366 = if any pred theta then
367 zonkInst inst `thenTc` \ inst' ->
368 tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) ->
369 partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
370 returnTc (lie1 `plusLIE` lie1',
371 lie2 `plusLIE` lie2',
372 binds1 `AndMonoBinds` binds2)
374 returnTc (lie1, consLIE inst lie2, binds1)
375 where maybe_theta = getMethodTheta_maybe inst
376 Just theta = maybe_theta
378 partPreds pred (lie1, lie2, binds) inst
379 = returnTc (lie1, consLIE inst lie2, binds)
383 %************************************************************************
385 \subsection{Data types for the reduction mechanism}
387 %************************************************************************
389 The main control over context reduction is here
393 = ReduceMe -- Try to reduce this
394 NoInstanceAction -- What to do if there's no such instance
396 | DontReduce -- Return as irreducible
398 | DontReduceUnlessConstant -- Return as irreducible unless it can
399 -- be reduced to a constant in one step
401 | Free -- Return as free
403 | FreeIfTautological -- Return as free iff it's tautological;
404 -- if not, return as irreducible
405 -- The FreeIfTautological case is to allow the possibility
406 -- of generating functions with types like
407 -- f :: C Int => Int -> Int
408 -- Here, the C Int isn't a tautology presumably because Int
409 -- isn't an instance of C in this module; but perhaps it will
410 -- be at f's call site(s). Haskell doesn't allow this at
413 data NoInstanceAction
414 = Stop -- Fail; no error message
415 -- (Only used when tautology checking.)
417 | AddToIrreds -- Just add the inst to the irreductible ones; don't
418 -- produce an error message of any kind.
419 -- It might be quite legitimate such as (Eq a)!
426 = (Avails s, -- What's available
427 [Inst], -- Insts for which try_me returned Free
428 [Inst] -- Insts for which try_me returned DontReduce
431 type Avails s = FiniteMap Inst Avail
435 TcId -- The "main Id"; that is, the Id for the Inst that
436 -- caused this avail to be put into the finite map in the first place
437 -- It is this Id that is bound to the RHS.
439 RHS -- The RHS: an expression whose value is that Inst.
440 -- The main Id should be bound to this RHS
442 [TcId] -- Extra Ids that must all be bound to the main Id.
443 -- At the end we generate a list of bindings
444 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
447 = NoRhs -- Used for irreducible dictionaries,
448 -- which are going to be lambda bound, or for those that are
449 -- suppplied as "given" when checking againgst a signature.
451 -- NoRhs is also used for Insts like (CCallable f)
452 -- where no witness is required.
454 | Rhs -- Used when there is a RHS
456 Bool -- True => the RHS simply selects a superclass dictionary
457 -- from a subclass dictionary.
459 -- This is useful info, because superclass selection
460 -- is cheaper than building the dictionary using its dfun,
461 -- and we can sometimes replace the latter with the former
463 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
464 -- an (Ord t) dictionary; then we put an (Eq t) entry in
465 -- the finite map, with an PassiveScSel. Then if the
466 -- the (Eq t) binding is ever *needed* we make it an Rhs
468 [Inst] -- List of Insts that are free in the RHS.
469 -- If the main Id is subsequently needed, we toss this list into
470 -- the needed-inst pool so that we make sure their bindings
471 -- will actually be produced.
473 -- Invariant: these Insts are already in the finite mapping
476 pprAvails avails = vcat (map pprAvail (eltsFM avails))
478 pprAvail (Avail main_id rhs ids)
479 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
481 instance Outputable Avail where
484 pprRhs NoRhs = text "<no rhs>"
485 pprRhs (Rhs rhs b) = ppr rhs
486 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
490 %************************************************************************
492 \subsection[reduce]{@reduce@}
494 %************************************************************************
496 The main entry point for context reduction is @reduceContext@:
499 reduceContext :: SDoc -> (Inst -> WhatToDo)
504 [Inst]) -- Irreducible
506 reduceContext str try_me givens wanteds
508 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
509 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
510 -- JRL - process fundeps last. We eliminate fundeps by seeing
511 -- what available classes generate them, so we need to process the
512 -- classes first. (would it be useful to make LIEs ordered in the first place?)
513 let (wantedOther, wantedFds) = partition notFunDep wanteds
514 wanteds' = wantedOther ++ wantedFds in
517 pprTrace "reduceContext" (vcat [
518 text "----------------------",
520 text "given" <+> ppr givens,
521 text "wanted" <+> ppr wanteds,
522 text "----------------------"
525 -- Build the Avail mapping from "givens"
526 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
529 reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) ->
531 -- Extract the bindings from avails
533 binds = foldFM add_bind EmptyMonoBinds avails
535 add_bind _ (Avail main_id rhs ids) binds
536 = foldr add_synonym (add_rhs_bind rhs binds) ids
538 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
539 add_rhs_bind other binds = binds
541 -- Add the trivial {x = y} bindings
542 -- The main Id can end up in the list when it's first added passively
543 -- and then activated, so we have to filter it out. A bit of a hack.
545 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
549 pprTrace ("reduceContext end") (vcat [
550 text "----------------------",
552 text "given" <+> ppr givens,
553 text "wanted" <+> ppr wanteds,
555 text "avails" <+> pprAvails avails,
556 text "frees" <+> ppr frees,
557 text "irreds" <+> ppr irreds,
558 text "----------------------"
561 returnNF_Tc (binds, frees, irreds)
564 The main context-reduction function is @reduce@. Here's its game plan.
567 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
568 -- along with its depth
569 -> (Inst -> WhatToDo)
576 try_me: given an inst, this function returns
578 DontReduce return this in "irreds"
579 Free return this in "frees"
581 wanteds: The list of insts to reduce
582 state: An accumulating parameter of type RedState
583 that contains the state of the algorithm
585 It returns a RedState.
587 The (n,stack) pair is just used for error reporting.
588 n is always the depth of the stack.
589 The stack is the stack of Insts being reduced: to produce X
590 I had to produce Y, to produce Y I had to produce Z, and so on.
593 reduceList (n,stack) try_me wanteds state
594 | n > opt_MaxContextReductionDepth
595 = failWithTc (reduceDepthErr n stack)
601 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
606 go [] state = returnTc state
607 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
610 -- Base case: we're done!
611 reduce stack try_me wanted state@(avails, frees, irreds)
612 -- It's the same as an existing inst, or a superclass thereof
613 | wanted `elemFM` avails
614 = returnTc (activate avails wanted, frees, irreds)
617 = case try_me wanted of {
619 ReduceMe no_instance_action -> -- It should be reduced
620 lookupInst wanted `thenNF_Tc` \ lookup_result ->
621 case lookup_result of
622 GenInst wanteds' rhs -> use_instance wanteds' rhs
623 SimpleInst rhs -> use_instance [] rhs
625 NoInstance -> -- No such instance!
626 case no_instance_action of
628 AddToIrreds -> add_to_irreds
630 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
631 -- First, see if the inst can be reduced to a constant in one step
632 lookupInst wanted `thenNF_Tc` \ lookup_result ->
633 case lookup_result of
634 SimpleInst rhs -> use_instance [] rhs
635 other -> add_to_frees
640 FreeIfTautological -> -- It's free and this is a top level binding, so
641 -- check whether it's a tautology or not
643 add_to_irreds -- If tautology trial fails, add to irreds
645 -- If tautology succeeds, just add to frees
646 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
647 returnTc (avails, wanted:frees, irreds))
652 DontReduce -> add_to_irreds
655 DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
656 -- See if the inst can be reduced to a constant in one step
657 lookupInst wanted `thenNF_Tc` \ lookup_result ->
658 case lookup_result of
659 SimpleInst rhs -> use_instance [] rhs
660 other -> add_to_irreds
663 -- The three main actions
665 avails' = addFree avails wanted
666 -- Add the thing to the avails set so any identical Insts
667 -- will be commoned up with it right here
669 returnTc (avails', wanted:frees, irreds)
671 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
672 returnTc (avails', frees, wanted:irreds)
674 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
675 reduceList stack try_me wanteds' (avails', frees, irreds)
678 -- The try-me to use when trying to identify tautologies
679 -- It blunders on reducing as much as possible
680 try_me_taut inst = ReduceMe Stop -- No error recovery
685 activate :: Avails s -> Inst -> Avails s
686 -- Activate the binding for Inst, ensuring that a binding for the
687 -- wanted Inst will be generated.
688 -- (Activate its parent if necessary, recursively).
689 -- Precondition: the Inst is in Avails already
691 activate avails wanted
692 | not (instBindingRequired wanted)
696 = case lookupFM avails wanted of
698 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
699 foldl activate avails' insts -- Activate anything it needs
701 avails' = addToFM avails wanted avail'
702 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
704 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
705 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
707 Nothing -> panic "activate"
709 wanted_id = instToId wanted
711 addWanted avails wanted rhs_expr
712 = ASSERT( not (wanted `elemFM` avails) )
713 addFunDeps (addToFM avails wanted avail) wanted
714 -- NB: we don't add the thing's superclasses too!
715 -- Why not? Because addWanted is used when we've successfully used an
716 -- instance decl to reduce something; e.g.
717 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
718 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
719 -- If we put the superclasses of "d" in avails, then we might end up
720 -- expressing "d1" in terms of "d", which would be a disaster.
722 avail = Avail (instToId wanted) rhs []
724 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
727 addFree :: Avails s -> Inst -> (Avails s)
728 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
729 -- to avails, so that any other equal Insts will be commoned up right
730 -- here rather than also being tossed upstairs. This is really just
731 -- an optimisation, and perhaps it is more trouble that it is worth,
732 -- as the following comments show!
734 -- NB1: do *not* add superclasses. If we have
737 -- but a is not bound here, then we *don't* want to derive
738 -- dn from df here lest we lose sharing.
740 -- NB2: do *not* add the Inst to avails at all if it's a method.
741 -- The following situation shows why this is bad:
742 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
743 -- From an application (truncate f i) we get
744 -- t1 = truncate at f
746 -- If we have also have a secon occurrence of truncate, we get
747 -- t3 = truncate at f
749 -- When simplifying with i,f free, we might still notice that
750 -- t1=t3; but alas, the binding for t2 (which mentions t1)
751 -- will continue to float out!
752 -- Solution: never put methods in avail till they are captured
753 -- in which case addFree isn't used
755 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
758 addGiven :: Avails s -> Inst -> NF_TcM (Avails s)
759 addGiven avails given
760 = -- ASSERT( not (given `elemFM` avails) )
761 -- This assertion isn't necessarily true. It's permitted
762 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
763 -- and when typechecking instance decls we generate redundant "givens" too.
764 -- addAvail avails given avail
765 addAvail avails given avail `thenNF_Tc` \av ->
766 zonkInst given `thenNF_Tc` \given' ->
769 avail = Avail (instToId given) NoRhs []
771 addAvail avails wanted avail
772 = addSuperClasses (addToFM avails wanted avail) wanted
774 addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s)
775 -- Add all the superclasses of the Inst to Avails
776 -- Invariant: the Inst is already in Avails.
778 addSuperClasses avails dict
779 | not (isClassDict dict)
782 | otherwise -- It is a dictionary
783 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
784 addFunDeps avails' dict
786 (clas, tys) = getDictClassTys dict
787 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
788 sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
790 add_sc avails ((super_clas, super_tys), sc_sel)
791 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
793 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
796 case lookupFM avails super_dict of
798 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
799 -- Already there, but not as a superclass selector
800 -- No need to look at its superclasses; since it's there
801 -- already they must be already in avails
802 -- However, we must remember to activate the dictionary
803 -- from which it is (now) generated
804 returnNF_Tc (activate avails' dict)
806 avails' = addToFM avails super_dict avail
807 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
809 Just (Avail _ _ _) -> returnNF_Tc avails
810 -- Already there; no need to do anything
813 -- Not there at all, so add it, and its superclasses
814 addAvail avails super_dict avail
816 avail = Avail (instToId super_dict)
817 (PassiveScSel sc_sel_rhs [dict])
820 addFunDeps :: Avails s -> Inst -> NF_TcM (Avails s)
821 -- Add in the functional dependencies generated by the inst
822 addFunDeps avails inst
823 = newFunDepFromDict inst `thenNF_Tc` \ fdInst_maybe ->
825 Nothing -> returnNF_Tc avails
827 let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
828 addAvail avails fdInst fdAvail
831 %************************************************************************
833 \subsection[simple]{@Simple@ versions}
835 %************************************************************************
837 Much simpler versions when there are no bindings to make!
839 @tcSimplifyThetas@ simplifies class-type constraints formed by
840 @deriving@ declarations and when specialising instances. We are
841 only interested in the simplified bunch of class/type constraints.
843 It simplifies to constraints of the form (C a b c) where
844 a,b,c are type variables. This is required for the context of
845 instance declarations.
848 tcSimplifyThetas :: ClassContext -- Wanted
849 -> TcM ClassContext -- Needed
851 tcSimplifyThetas wanteds
852 = reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
854 -- For multi-param Haskell, check that the returned dictionaries
855 -- don't have any of the form (C Int Bool) for which
856 -- we expect an instance here
857 -- For Haskell 98, check that all the constraints are of the form C a,
858 -- where a is a type variable
859 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
860 isEmptyVarSet (tyVarsOfTypes tys)]
861 | otherwise = [ct | ct@(clas,tys) <- irreds,
862 not (all isTyVarTy tys)]
864 if null bad_guys then
867 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
871 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
872 used with \tr{default} declarations. We are only interested in
873 whether it worked or not.
876 tcSimplifyCheckThetas :: ClassContext -- Given
877 -> ClassContext -- Wanted
880 tcSimplifyCheckThetas givens wanteds
881 = reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
885 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
891 type AvailsSimple = FiniteMap (Class,[Type]) Bool
892 -- True => irreducible
893 -- False => given, or can be derived from a given or from an irreducible
895 reduceSimple :: ClassContext -- Given
896 -> ClassContext -- Wanted
897 -> NF_TcM ClassContext -- Irreducible
899 reduceSimple givens wanteds
900 = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
901 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
903 givens_fm = foldl addNonIrred emptyFM givens
905 reduce_simple :: (Int,ClassContext) -- Stack
908 -> NF_TcM AvailsSimple
910 reduce_simple (n,stack) avails wanteds
913 go avails [] = returnNF_Tc avails
914 go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
917 reduce_simple_help stack givens wanted@(clas,tys)
918 | wanted `elemFM` givens
922 = lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
925 Nothing -> returnNF_Tc (addIrred givens wanted)
926 Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
928 addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
929 addIrred givens ct@(clas,tys)
930 = addSCs (addToFM givens ct True) ct
932 addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
933 addNonIrred givens ct@(clas,tys)
934 = addSCs (addToFM givens ct False) ct
936 addSCs givens ct@(clas,tys)
937 = foldl add givens sc_theta
939 (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
940 sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
942 add givens ct@(clas, tys)
943 = case lookupFM givens ct of
944 Nothing -> -- Add it and its superclasses
945 addSCs (addToFM givens ct False) ct
947 Just True -> -- Set its flag to False; superclasses already done
948 addToFM givens ct False
950 Just False -> -- Already done
955 %************************************************************************
957 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
959 %************************************************************************
961 When doing a binding group, we may have @Insts@ of local functions.
962 For example, we might have...
964 let f x = x + 1 -- orig local function (overloaded)
965 f.1 = f Int -- two instances of f
970 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
971 where @f@ is in scope; those @Insts@ must certainly not be passed
972 upwards towards the top-level. If the @Insts@ were binding-ified up
973 there, they would have unresolvable references to @f@.
975 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
976 For each method @Inst@ in the @init_lie@ that mentions one of the
977 @Ids@, we create a binding. We return the remaining @Insts@ (in an
978 @LIE@), as well as the @HsBinds@ generated.
981 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
983 bindInstsOfLocalFuns init_lie local_ids
984 | null overloaded_ids || null lie_for_here
986 = returnTc (init_lie, EmptyMonoBinds)
989 = reduceContext (text "bindInsts" <+> ppr local_ids)
990 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
991 ASSERT( null irreds )
992 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
994 overloaded_ids = filter is_overloaded local_ids
995 is_overloaded id = case splitSigmaTy (idType id) of
996 (_, theta, _) -> not (null theta)
998 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
999 -- so it's worth building a set, so that
1000 -- lookup (in isMethodFor) is faster
1002 -- No sense in repeatedly zonking lots of
1003 -- constant constraints so filter them out here
1004 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
1005 (lieToList init_lie)
1006 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
1011 %************************************************************************
1013 \section[Disambig]{Disambiguation of overloading}
1015 %************************************************************************
1018 If a dictionary constrains a type variable which is
1021 not mentioned in the environment
1023 and not mentioned in the type of the expression
1025 then it is ambiguous. No further information will arise to instantiate
1026 the type variable; nor will it be generalised and turned into an extra
1027 parameter to a function.
1029 It is an error for this to occur, except that Haskell provided for
1030 certain rules to be applied in the special case of numeric types.
1035 at least one of its classes is a numeric class, and
1037 all of its classes are numeric or standard
1039 then the type variable can be defaulted to the first type in the
1040 default-type list which is an instance of all the offending classes.
1042 So here is the function which does the work. It takes the ambiguous
1043 dictionaries and either resolves them (producing bindings) or
1044 complains. It works by splitting the dictionary list by type
1045 variable, and using @disambigOne@ to do the real business.
1048 @tcSimplifyTop@ is called once per module to simplify
1049 all the constant and ambiguous Insts.
1052 tcSimplifyTop :: LIE -> TcM TcDictBinds
1053 tcSimplifyTop wanted_lie
1054 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
1055 ASSERT( null frees )
1058 -- All the non-std ones are definite errors
1059 (stds, non_stds) = partition isStdClassTyVarDict irreds
1062 -- Group by type variable
1063 std_groups = equivClasses cmp_by_tyvar stds
1065 -- Pick the ones which its worth trying to disambiguate
1066 (std_oks, std_bads) = partition worth_a_try std_groups
1067 -- Have a try at disambiguation
1068 -- if the type variable isn't bound
1069 -- up with one of the non-standard classes
1070 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
1071 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
1073 -- Collect together all the bad guys
1074 bad_guys = non_stds ++ concat std_bads
1077 -- Disambiguate the ones that look feasible
1078 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
1080 -- And complain about the ones that don't
1081 mapNF_Tc complain bad_guys `thenNF_Tc_`
1083 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1085 wanteds = lieToList wanted_lie
1086 try_me inst = ReduceMe AddToIrreds
1088 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1090 complain d | not (null (getIPs d)) = addTopIPErr d
1091 | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1092 | otherwise = addAmbigErr tyVarsOfInst d
1094 get_tv d = case getDictClassTys d of
1095 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1096 get_clas d = case getDictClassTys d of
1097 (clas, [ty]) -> clas
1100 @disambigOne@ assumes that its arguments dictionaries constrain all
1101 the same type variable.
1103 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1104 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1105 the most common use of defaulting is code like:
1107 _ccall_ foo `seqPrimIO` bar
1109 Since we're not using the result of @foo@, the result if (presumably)
1113 disambigGroup :: [Inst] -- All standard classes of form (C a)
1117 | any isNumericClass classes -- Guaranteed all standard classes
1118 -- see comment at the end of function for reasons as to
1119 -- why the defaulting mechanism doesn't apply to groups that
1120 -- include CCallable or CReturnable dicts.
1121 && not (any isCcallishClass classes)
1122 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1123 -- SO, TRY DEFAULT TYPES IN ORDER
1125 -- Failure here is caused by there being no type in the
1126 -- default list which can satisfy all the ambiguous classes.
1127 -- For example, if Real a is reqd, but the only type in the
1128 -- default list is Int.
1129 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1131 try_default [] -- No defaults work, so fail
1134 try_default (default_ty : default_tys)
1135 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1136 -- default_tys instead
1137 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1140 thetas = classes `zip` repeat [default_ty]
1142 -- See if any default works, and if so bind the type variable to it
1143 -- If not, add an AmbigErr
1144 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1146 try_default default_tys `thenTc` \ chosen_default_ty ->
1148 -- Bind the type variable and reduce the context, for real this time
1149 unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_`
1150 reduceContext (text "disambig" <+> ppr dicts)
1151 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1152 ASSERT( null frees && null ambigs )
1153 warnDefault dicts chosen_default_ty `thenTc_`
1156 | all isCreturnableClass classes
1157 = -- Default CCall stuff to (); we don't even both to check that () is an
1158 -- instance of CReturnable, because we know it is.
1159 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1160 returnTc EmptyMonoBinds
1162 | otherwise -- No defaults
1163 = complain dicts `thenNF_Tc_`
1164 returnTc EmptyMonoBinds
1167 complain = addAmbigErrs tyVarsOfInst
1168 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1169 tyvar = get_tv (head dicts) -- Should be non-empty
1170 classes = map get_clas dicts
1173 [Aside - why the defaulting mechanism is turned off when
1174 dealing with arguments and results to ccalls.
1176 When typechecking _ccall_s, TcExpr ensures that the external
1177 function is only passed arguments (and in the other direction,
1178 results) of a restricted set of 'native' types. This is
1179 implemented via the help of the pseudo-type classes,
1180 @CReturnable@ (CR) and @CCallable@ (CC.)
1182 The interaction between the defaulting mechanism for numeric
1183 values and CC & CR can be a bit puzzling to the user at times.
1192 What type has 'x' got here? That depends on the default list
1193 in operation, if it is equal to Haskell 98's default-default
1194 of (Integer, Double), 'x' has type Double, since Integer
1195 is not an instance of CR. If the default list is equal to
1196 Haskell 1.4's default-default of (Int, Double), 'x' has type
1199 To try to minimise the potential for surprises here, the
1200 defaulting mechanism is turned off in the presence of
1201 CCallable and CReturnable.
1207 ToDo: for these error messages, should we note the location as coming
1208 from the insts, or just whatever seems to be around in the monad just
1212 genCantGenErr insts -- Can't generalise these Insts
1213 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1214 nest 4 (pprInstsInFull insts)
1217 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1219 addAmbigErr ambig_tv_fn dict
1220 = addInstErrTcM (instLoc dict)
1222 sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
1223 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1225 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1226 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1228 warnDefault dicts default_ty
1229 | not opt_WarnTypeDefaults
1235 msg | length dicts > 1
1236 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1237 $$ pprInstsInFull tidy_dicts
1239 = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1240 ptext SLIT("to type") <+> quotes (ppr default_ty)
1242 (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1245 = addInstErrTcM (instLoc dict)
1247 ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
1249 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1251 -- Used for top-level irreducibles
1252 addTopInstanceErr dict
1253 = addInstErrTcM (instLoc dict)
1255 ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1257 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1259 -- The error message when we don't find a suitable instance
1260 -- is complicated by the fact that sometimes this is because
1261 -- there is no instance, and sometimes it's because there are
1262 -- too many instances (overlap). See the comments in TcEnv.lhs
1263 -- with the InstEnv stuff.
1264 addNoInstanceErr str givens dict
1265 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
1267 doc = vcat [herald <+> quotes (pprInst tidy_dict),
1268 nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
1270 ptext SLIT("Probable fix:"),
1274 herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
1275 unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
1279 | not ambig_overlap = empty
1281 = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
1282 nest 4 (ptext SLIT("depends on the instantiation of") <+>
1283 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
1285 fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
1286 ptext SLIT("to the") <+> str]
1288 fix2 | isTyVarDict dict || ambig_overlap
1291 = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
1293 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1295 -- Checks for the ambiguous case when we have overlapping instances
1296 ambig_overlap | isClassDict dict
1297 = case lookupInstEnv inst_env clas tys of
1298 NoMatch ambig -> ambig
1302 (clas,tys) = getDictClassTys dict
1304 addInstErrTcM (instLoc dict) (tidy_env, doc)
1306 -- Used for the ...Thetas variants; all top level
1308 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1310 reduceDepthErr n stack
1311 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1312 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1313 nest 4 (pprInstsInFull stack)]
1315 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)