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(..),
134 tyVarsOfInst, tyVarsOfInsts,
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 )
147 import TcType ( TcType, TcTyVarSet, typeToTcType )
148 import TcUnify ( unifyTauTy )
150 import Class ( Class, classBigSig, classInstEnv )
151 import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
153 import Type ( Type, ThetaType, TauType, ClassContext,
155 isTyVarTy, splitSigmaTy, tyVarsOfTypes
157 import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
158 import Subst ( mkTopTyVarSubst, substClasses )
159 import PprType ( pprConstraint )
160 import TysWiredIn ( unitTy )
163 import BasicTypes ( TopLevelFlag(..) )
164 import CmdLineOpts ( opt_GlasgowExts )
167 import List ( partition )
168 import Maybe ( fromJust )
169 import Maybes ( maybeToBool )
173 %************************************************************************
175 \subsection[tcSimplify-main]{Main entry function}
177 %************************************************************************
179 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
180 the ``don't-squash-consts'' flag set depending on top-level ness. For
181 top level defns we *do* squash constants, so that they stay local to a
182 single defn. This makes things which are inlined more likely to be
183 exportable, because their constants are "inside". Later passes will
184 float them out if poss, after inlinings are sorted out.
189 -> TcTyVarSet -- ``Local'' type variables
190 -- ASSERT: this tyvar set is already zonked
192 -> TcM s (LIE, -- Free
193 TcDictBinds, -- Bindings
194 LIE) -- Remaining wanteds; no dups
196 tcSimplify str local_tvs wanted_lie
197 {- this is just an optimization, and interferes with implicit params,
198 disable it for now. same goes for tcSimplifyAndCheck
199 | isEmptyVarSet local_tvs
200 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
204 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
206 -- Check for non-generalisable insts
208 cant_generalise = filter (not . instCanBeGeneralised) irreds
210 checkTc (null cant_generalise)
211 (genCantGenErr cant_generalise) `thenTc_`
213 -- Check for ambiguous insts.
214 -- You might think these can't happen (I did) because an ambiguous
215 -- inst like (Eq a) will get tossed out with "frees", and eventually
216 -- dealt with by tcSimplifyTop.
217 -- But we can get stuck with
219 -- where "a" is one of the local_tvs, but "b" is unconstrained.
220 -- Then we must yell about the ambiguous b
221 -- But we must only do so if "b" really is unconstrained; so
222 -- we must grab the global tyvars to answer that question
223 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
225 avail_tvs = local_tvs `unionVarSet` global_tvs
226 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
227 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
229 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
233 returnTc (mkLIE frees, binds, mkLIE irreds')
235 wanteds = lieToList wanted_lie
238 -- Does not constrain a local tyvar
239 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
240 && null (getIPs inst)
241 = -- if is_top_level then
242 -- FreeIfTautological -- Special case for inference on
243 -- -- top-level defns
247 -- We're infering (not checking) the type, and
248 -- the inst constrains a local type variable
249 | isClassDict inst = DontReduceUnlessConstant -- Dicts
250 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
253 @tcSimplifyAndCheck@ is similar to the above, except that it checks
254 that there is an empty wanted-set at the end. It may still return
255 some of constant insts, which have to be resolved finally at the end.
260 -> TcTyVarSet -- ``Local'' type variables
261 -- ASSERT: this tyvar set is already zonked
262 -> LIE -- Given; constrain only local tyvars
264 -> TcM s (LIE, -- Free
265 TcDictBinds) -- Bindings
267 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
269 | isEmptyVarSet local_tvs
270 -- This can happen quite legitimately; for example in
271 -- instance Num Int where ...
272 = returnTc (wanted_lie, EmptyMonoBinds)
276 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
278 -- Complain about any irreducible ones
279 mapNF_Tc complain irreds `thenNF_Tc_`
282 returnTc (mkLIE frees, binds)
284 givens = lieToList given_lie
285 wanteds = lieToList wanted_lie
286 given_dicts = filter isClassDict givens
289 -- Does not constrain a local tyvar
290 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
291 && (not (isMethod inst) || null (getIPs inst))
294 -- When checking against a given signature we always reduce
295 -- until we find a match against something given, or can't reduce
297 = ReduceMe AddToIrreds
299 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
300 addNoInstanceErr str given_dicts dict
303 On the LHS of transformation rules we only simplify methods and constants,
304 getting dictionaries. We want to keep all of them unsimplified, to serve
305 as the available stuff for the RHS of the rule.
307 The same thing is used for specialise pragmas. Consider
310 {-# SPECIALISE f :: Int -> Int #-}
313 The type checker generates a binding like:
315 f_spec = (f :: Int -> Int)
317 and we want to end up with
319 f_spec = _inline_me_ (f Int dNumInt)
321 But that means that we must simplify the Method for f to (f Int dNumInt)!
322 So tcSimplifyToDicts squeezes out all Methods.
325 tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
326 tcSimplifyToDicts wanted_lie
327 = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
329 returnTc (mkLIE irreds, binds)
331 wanteds = lieToList wanted_lie
333 -- Reduce methods and lits only; stop as soon as we get a dictionary
334 try_me inst | isDict inst = DontReduce
335 | otherwise = ReduceMe AddToIrreds
338 The following function partitions a LIE by a predicate defined
339 over `Pred'icates (an unfortunate overloading of terminology!).
340 This means it sometimes has to split up `Methods', in which case
341 a binding is generated.
343 It is used in `with' bindings to extract from the LIE the implicit
344 parameters being bound.
347 partitionPredsOfLIE pred lie
348 = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
349 where insts = lieToList lie
351 -- warning: the term `pred' is overloaded here!
352 partPreds pred (lie1, lie2, binds) inst
353 | maybeToBool maybe_pred
355 returnTc (consLIE inst lie1, lie2, binds)
357 returnTc (lie1, consLIE inst lie2, binds)
358 where maybe_pred = getDictPred_maybe inst
361 -- the assumption is that those satisfying `pred' are being extracted,
362 -- so we leave the method untouched when nothing satisfies `pred'
363 partPreds pred (lie1, lie2, binds1) inst
364 | maybeToBool maybe_theta
365 = if any pred theta then
366 zonkInst inst `thenTc` \ inst' ->
367 tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) ->
368 partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
369 returnTc (lie1 `plusLIE` lie1',
370 lie2 `plusLIE` lie2',
371 binds1 `AndMonoBinds` binds2)
373 returnTc (lie1, consLIE inst lie2, binds1)
374 where maybe_theta = getMethodTheta_maybe inst
375 Just theta = maybe_theta
377 partPreds pred (lie1, lie2, binds) inst
378 = returnTc (lie1, consLIE inst lie2, binds)
382 %************************************************************************
384 \subsection{Data types for the reduction mechanism}
386 %************************************************************************
388 The main control over context reduction is here
392 = ReduceMe -- Try to reduce this
393 NoInstanceAction -- What to do if there's no such instance
395 | DontReduce -- Return as irreducible
397 | DontReduceUnlessConstant -- Return as irreducible unless it can
398 -- be reduced to a constant in one step
400 | Free -- Return as free
402 | FreeIfTautological -- Return as free iff it's tautological;
403 -- if not, return as irreducible
404 -- The FreeIfTautological case is to allow the possibility
405 -- of generating functions with types like
406 -- f :: C Int => Int -> Int
407 -- Here, the C Int isn't a tautology presumably because Int
408 -- isn't an instance of C in this module; but perhaps it will
409 -- be at f's call site(s). Haskell doesn't allow this at
412 data NoInstanceAction
413 = Stop -- Fail; no error message
414 -- (Only used when tautology checking.)
416 | AddToIrreds -- Just add the inst to the irreductible ones; don't
417 -- produce an error message of any kind.
418 -- It might be quite legitimate such as (Eq a)!
425 = (Avails s, -- What's available
426 [Inst], -- Insts for which try_me returned Free
427 [Inst] -- Insts for which try_me returned DontReduce
430 type Avails s = FiniteMap Inst Avail
434 TcId -- The "main Id"; that is, the Id for the Inst that
435 -- caused this avail to be put into the finite map in the first place
436 -- It is this Id that is bound to the RHS.
438 RHS -- The RHS: an expression whose value is that Inst.
439 -- The main Id should be bound to this RHS
441 [TcId] -- Extra Ids that must all be bound to the main Id.
442 -- At the end we generate a list of bindings
443 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
446 = NoRhs -- Used for irreducible dictionaries,
447 -- which are going to be lambda bound, or for those that are
448 -- suppplied as "given" when checking againgst a signature.
450 -- NoRhs is also used for Insts like (CCallable f)
451 -- where no witness is required.
453 | Rhs -- Used when there is a RHS
455 Bool -- True => the RHS simply selects a superclass dictionary
456 -- from a subclass dictionary.
458 -- This is useful info, because superclass selection
459 -- is cheaper than building the dictionary using its dfun,
460 -- and we can sometimes replace the latter with the former
462 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
463 -- an (Ord t) dictionary; then we put an (Eq t) entry in
464 -- the finite map, with an PassiveScSel. Then if the
465 -- the (Eq t) binding is ever *needed* we make it an Rhs
467 [Inst] -- List of Insts that are free in the RHS.
468 -- If the main Id is subsequently needed, we toss this list into
469 -- the needed-inst pool so that we make sure their bindings
470 -- will actually be produced.
472 -- Invariant: these Insts are already in the finite mapping
475 pprAvails avails = vcat (map pprAvail (eltsFM avails))
477 pprAvail (Avail main_id rhs ids)
478 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
480 instance Outputable Avail where
483 pprRhs NoRhs = text "<no rhs>"
484 pprRhs (Rhs rhs b) = ppr rhs
485 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
489 %************************************************************************
491 \subsection[reduce]{@reduce@}
493 %************************************************************************
495 The main entry point for context reduction is @reduceContext@:
498 reduceContext :: SDoc -> (Inst -> WhatToDo)
501 -> TcM s (TcDictBinds,
503 [Inst]) -- Irreducible
505 reduceContext str try_me givens wanteds
507 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
508 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
509 -- JRL - process fundeps last. We eliminate fundeps by seeing
510 -- what available classes generate them, so we need to process the
511 -- classes first. (would it be useful to make LIEs ordered in the first place?)
512 let (wantedOther, wantedFds) = partition notFunDep wanteds
513 wanteds' = wantedOther ++ wantedFds in
516 pprTrace "reduceContext" (vcat [
517 text "----------------------",
519 text "given" <+> ppr givens,
520 text "wanted" <+> ppr wanteds,
521 text "----------------------"
524 -- Build the Avail mapping from "givens"
525 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
528 reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) ->
530 -- Extract the bindings from avails
532 binds = foldFM add_bind EmptyMonoBinds avails
534 add_bind _ (Avail main_id rhs ids) binds
535 = foldr add_synonym (add_rhs_bind rhs binds) ids
537 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
538 add_rhs_bind other binds = binds
540 -- Add the trivial {x = y} bindings
541 -- The main Id can end up in the list when it's first added passively
542 -- and then activated, so we have to filter it out. A bit of a hack.
544 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
548 pprTrace ("reduceContext end") (vcat [
549 text "----------------------",
551 text "given" <+> ppr givens,
552 text "wanted" <+> ppr wanteds,
554 text "avails" <+> pprAvails avails,
555 text "frees" <+> ppr frees,
556 text "irreds" <+> ppr irreds,
557 text "----------------------"
560 returnNF_Tc (binds, frees, irreds)
563 The main context-reduction function is @reduce@. Here's its game plan.
566 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
567 -- along with its depth
568 -> (Inst -> WhatToDo)
571 -> TcM s (RedState s)
575 try_me: given an inst, this function returns
577 DontReduce return this in "irreds"
578 Free return this in "frees"
580 wanteds: The list of insts to reduce
581 state: An accumulating parameter of type RedState
582 that contains the state of the algorithm
584 It returns a RedState.
586 The (n,stack) pair is just used for error reporting.
587 n is always the depth of the stack.
588 The stack is the stack of Insts being reduced: to produce X
589 I had to produce Y, to produce Y I had to produce Z, and so on.
592 reduceList (n,stack) try_me wanteds state
593 | n > opt_MaxContextReductionDepth
594 = failWithTc (reduceDepthErr n stack)
600 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
605 go [] state = returnTc state
606 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
609 -- Base case: we're done!
610 reduce stack try_me wanted state@(avails, frees, irreds)
611 -- It's the same as an existing inst, or a superclass thereof
612 | wanted `elemFM` avails
613 = returnTc (activate avails wanted, frees, irreds)
616 = case try_me wanted of {
618 ReduceMe no_instance_action -> -- It should be reduced
619 lookupInst wanted `thenNF_Tc` \ lookup_result ->
620 case lookup_result of
621 GenInst wanteds' rhs -> use_instance wanteds' rhs
622 SimpleInst rhs -> use_instance [] rhs
624 NoInstance -> -- No such instance!
625 case no_instance_action of
627 AddToIrreds -> add_to_irreds
629 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
630 -- First, see if the inst can be reduced to a constant in one step
631 lookupInst wanted `thenNF_Tc` \ lookup_result ->
632 case lookup_result of
633 SimpleInst rhs -> use_instance [] rhs
634 other -> add_to_frees
639 FreeIfTautological -> -- It's free and this is a top level binding, so
640 -- check whether it's a tautology or not
642 add_to_irreds -- If tautology trial fails, add to irreds
644 -- If tautology succeeds, just add to frees
645 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
646 returnTc (avails, wanted:frees, irreds))
651 DontReduce -> add_to_irreds
654 DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
655 -- See if the inst can be reduced to a constant in one step
656 lookupInst wanted `thenNF_Tc` \ lookup_result ->
657 case lookup_result of
658 SimpleInst rhs -> use_instance [] rhs
659 other -> add_to_irreds
662 -- The three main actions
664 avails' = addFree avails wanted
665 -- Add the thing to the avails set so any identical Insts
666 -- will be commoned up with it right here
668 returnTc (avails', wanted:frees, irreds)
670 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
671 returnTc (avails', frees, wanted:irreds)
673 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
674 reduceList stack try_me wanteds' (avails', frees, irreds)
677 -- The try-me to use when trying to identify tautologies
678 -- It blunders on reducing as much as possible
679 try_me_taut inst = ReduceMe Stop -- No error recovery
684 activate :: Avails s -> Inst -> Avails s
685 -- Activate the binding for Inst, ensuring that a binding for the
686 -- wanted Inst will be generated.
687 -- (Activate its parent if necessary, recursively).
688 -- Precondition: the Inst is in Avails already
690 activate avails wanted
691 | not (instBindingRequired wanted)
695 = case lookupFM avails wanted of
697 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
698 foldl activate avails' insts -- Activate anything it needs
700 avails' = addToFM avails wanted avail'
701 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
703 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
704 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
706 Nothing -> panic "activate"
708 wanted_id = instToId wanted
710 addWanted avails wanted rhs_expr
711 = ASSERT( not (wanted `elemFM` avails) )
712 returnNF_Tc (addToFM avails wanted avail)
713 -- NB: we don't add the thing's superclasses too!
714 -- Why not? Because addWanted is used when we've successfully used an
715 -- instance decl to reduce something; e.g.
716 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
717 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
718 -- If we put the superclasses of "d" in avails, then we might end up
719 -- expressing "d1" in terms of "d", which would be a disaster.
721 avail = Avail (instToId wanted) rhs []
723 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
726 addFree :: Avails s -> Inst -> (Avails s)
727 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
728 -- to avails, so that any other equal Insts will be commoned up right
729 -- here rather than also being tossed upstairs. This is really just
730 -- an optimisation, and perhaps it is more trouble that it is worth,
731 -- as the following comments show!
733 -- NB1: do *not* add superclasses. If we have
736 -- but a is not bound here, then we *don't* want to derive
737 -- dn from df here lest we lose sharing.
739 -- NB2: do *not* add the Inst to avails at all if it's a method.
740 -- The following situation shows why this is bad:
741 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
742 -- From an application (truncate f i) we get
743 -- t1 = truncate at f
745 -- If we have also have a secon occurrence of truncate, we get
746 -- t3 = truncate at f
748 -- When simplifying with i,f free, we might still notice that
749 -- t1=t3; but alas, the binding for t2 (which mentions t1)
750 -- will continue to float out!
751 -- Solution: never put methods in avail till they are captured
752 -- in which case addFree isn't used
754 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
757 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
758 addGiven avails given
759 = -- ASSERT( not (given `elemFM` avails) )
760 -- This assertion isn't necessarily true. It's permitted
761 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
762 -- and when typechecking instance decls we generate redundant "givens" too.
763 -- addAvail avails given avail
764 addAvail avails given avail `thenNF_Tc` \av ->
765 zonkInst given `thenNF_Tc` \given' ->
768 avail = Avail (instToId given) NoRhs []
770 addAvail avails wanted avail
771 = addSuperClasses (addToFM avails wanted avail) wanted
773 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
774 -- Add all the superclasses of the Inst to Avails
775 -- JRL - also add in the functional dependencies
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 newFunDepFromDict dict `thenNF_Tc` \ fdInst_maybe ->
786 Nothing -> returnNF_Tc avails'
788 let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
789 addAvail avails fdInst fdAvail
791 (clas, tys) = getDictClassTys dict
792 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
793 sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
795 add_sc avails ((super_clas, super_tys), sc_sel)
796 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
798 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
801 case lookupFM avails super_dict of
803 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
804 -- Already there, but not as a superclass selector
805 -- No need to look at its superclasses; since it's there
806 -- already they must be already in avails
807 -- However, we must remember to activate the dictionary
808 -- from which it is (now) generated
809 returnNF_Tc (activate avails' dict)
811 avails' = addToFM avails super_dict avail
812 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
814 Just (Avail _ _ _) -> returnNF_Tc avails
815 -- Already there; no need to do anything
818 -- Not there at all, so add it, and its superclasses
819 addAvail avails super_dict avail
821 avail = Avail (instToId super_dict)
822 (PassiveScSel sc_sel_rhs [dict])
826 %************************************************************************
828 \subsection[simple]{@Simple@ versions}
830 %************************************************************************
832 Much simpler versions when there are no bindings to make!
834 @tcSimplifyThetas@ simplifies class-type constraints formed by
835 @deriving@ declarations and when specialising instances. We are
836 only interested in the simplified bunch of class/type constraints.
838 It simplifies to constraints of the form (C a b c) where
839 a,b,c are type variables. This is required for the context of
840 instance declarations.
843 tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
844 -> ClassContext -- Wanted
845 -> TcM s ClassContext -- Needed
847 tcSimplifyThetas inst_mapper wanteds
848 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
850 -- For multi-param Haskell, check that the returned dictionaries
851 -- don't have any of the form (C Int Bool) for which
852 -- we expect an instance here
853 -- For Haskell 98, check that all the constraints are of the form C a,
854 -- where a is a type variable
855 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
856 isEmptyVarSet (tyVarsOfTypes tys)]
857 | otherwise = [ct | ct@(clas,tys) <- irreds,
858 not (all isTyVarTy tys)]
860 if null bad_guys then
863 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
867 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
868 used with \tr{default} declarations. We are only interested in
869 whether it worked or not.
872 tcSimplifyCheckThetas :: ClassContext -- Given
873 -> ClassContext -- Wanted
876 tcSimplifyCheckThetas givens wanteds
877 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
881 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
887 type AvailsSimple = FiniteMap (Class,[Type]) Bool
888 -- True => irreducible
889 -- False => given, or can be derived from a given or from an irreducible
891 reduceSimple :: (Class -> InstEnv)
892 -> ClassContext -- Given
893 -> ClassContext -- Wanted
894 -> NF_TcM s ClassContext -- Irreducible
896 reduceSimple inst_mapper givens wanteds
897 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
898 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
900 givens_fm = foldl addNonIrred emptyFM givens
902 reduce_simple :: (Int,ClassContext) -- Stack
903 -> (Class -> InstEnv)
906 -> NF_TcM s AvailsSimple
908 reduce_simple (n,stack) inst_mapper avails wanteds
911 go avails [] = returnNF_Tc avails
912 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
915 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
916 | wanted `elemFM` givens
920 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
923 Nothing -> returnNF_Tc (addIrred givens wanted)
924 Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
926 addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
927 addIrred givens ct@(clas,tys)
928 = addSCs (addToFM givens ct True) ct
930 addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
931 addNonIrred givens ct@(clas,tys)
932 = addSCs (addToFM givens ct False) ct
934 addSCs givens ct@(clas,tys)
935 = foldl add givens sc_theta
937 (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
938 sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
940 add givens ct@(clas, tys)
941 = case lookupFM givens ct of
942 Nothing -> -- Add it and its superclasses
943 addSCs (addToFM givens ct False) ct
945 Just True -> -- Set its flag to False; superclasses already done
946 addToFM givens ct False
948 Just False -> -- Already done
953 %************************************************************************
955 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
957 %************************************************************************
959 When doing a binding group, we may have @Insts@ of local functions.
960 For example, we might have...
962 let f x = x + 1 -- orig local function (overloaded)
963 f.1 = f Int -- two instances of f
968 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
969 where @f@ is in scope; those @Insts@ must certainly not be passed
970 upwards towards the top-level. If the @Insts@ were binding-ified up
971 there, they would have unresolvable references to @f@.
973 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
974 For each method @Inst@ in the @init_lie@ that mentions one of the
975 @Ids@, we create a binding. We return the remaining @Insts@ (in an
976 @LIE@), as well as the @HsBinds@ generated.
979 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
981 bindInstsOfLocalFuns init_lie local_ids
982 | null overloaded_ids || null lie_for_here
984 = returnTc (init_lie, EmptyMonoBinds)
987 = reduceContext (text "bindInsts" <+> ppr local_ids)
988 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
989 ASSERT( null irreds )
990 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
992 overloaded_ids = filter is_overloaded local_ids
993 is_overloaded id = case splitSigmaTy (idType id) of
994 (_, theta, _) -> not (null theta)
996 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
997 -- so it's worth building a set, so that
998 -- lookup (in isMethodFor) is faster
1000 -- No sense in repeatedly zonking lots of
1001 -- constant constraints so filter them out here
1002 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
1003 (lieToList init_lie)
1004 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
1009 %************************************************************************
1011 \section[Disambig]{Disambiguation of overloading}
1013 %************************************************************************
1016 If a dictionary constrains a type variable which is
1019 not mentioned in the environment
1021 and not mentioned in the type of the expression
1023 then it is ambiguous. No further information will arise to instantiate
1024 the type variable; nor will it be generalised and turned into an extra
1025 parameter to a function.
1027 It is an error for this to occur, except that Haskell provided for
1028 certain rules to be applied in the special case of numeric types.
1033 at least one of its classes is a numeric class, and
1035 all of its classes are numeric or standard
1037 then the type variable can be defaulted to the first type in the
1038 default-type list which is an instance of all the offending classes.
1040 So here is the function which does the work. It takes the ambiguous
1041 dictionaries and either resolves them (producing bindings) or
1042 complains. It works by splitting the dictionary list by type
1043 variable, and using @disambigOne@ to do the real business.
1046 @tcSimplifyTop@ is called once per module to simplify
1047 all the constant and ambiguous Insts.
1050 tcSimplifyTop :: LIE -> TcM s TcDictBinds
1051 tcSimplifyTop wanted_lie
1052 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
1053 ASSERT( null frees )
1056 -- All the non-std ones are definite errors
1057 (stds, non_stds) = partition isStdClassTyVarDict irreds
1060 -- Group by type variable
1061 std_groups = equivClasses cmp_by_tyvar stds
1063 -- Pick the ones which its worth trying to disambiguate
1064 (std_oks, std_bads) = partition worth_a_try std_groups
1065 -- Have a try at disambiguation
1066 -- if the type variable isn't bound
1067 -- up with one of the non-standard classes
1068 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
1069 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
1071 -- Collect together all the bad guys
1072 bad_guys = non_stds ++ concat std_bads
1075 -- Disambiguate the ones that look feasible
1076 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
1078 -- And complain about the ones that don't
1079 mapNF_Tc complain bad_guys `thenNF_Tc_`
1081 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1083 wanteds = lieToList wanted_lie
1084 try_me inst = ReduceMe AddToIrreds
1086 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1088 complain d | not (null (getIPs d)) = addTopIPErr d
1089 | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1090 | otherwise = addAmbigErr tyVarsOfInst d
1092 get_tv d = case getDictClassTys d of
1093 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1094 get_clas d = case getDictClassTys d of
1095 (clas, [ty]) -> clas
1098 @disambigOne@ assumes that its arguments dictionaries constrain all
1099 the same type variable.
1101 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1102 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1103 the most common use of defaulting is code like:
1105 _ccall_ foo `seqPrimIO` bar
1107 Since we're not using the result of @foo@, the result if (presumably)
1111 disambigGroup :: [Inst] -- All standard classes of form (C a)
1112 -> TcM s TcDictBinds
1115 | any isNumericClass classes -- Guaranteed all standard classes
1116 -- see comment at the end of function for reasons as to
1117 -- why the defaulting mechanism doesn't apply to groups that
1118 -- include CCallable or CReturnable dicts.
1119 && not (any isCcallishClass classes)
1120 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1121 -- SO, TRY DEFAULT TYPES IN ORDER
1123 -- Failure here is caused by there being no type in the
1124 -- default list which can satisfy all the ambiguous classes.
1125 -- For example, if Real a is reqd, but the only type in the
1126 -- default list is Int.
1127 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1129 try_default [] -- No defaults work, so fail
1132 try_default (default_ty : default_tys)
1133 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1134 -- default_tys instead
1135 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1138 thetas = classes `zip` repeat [default_ty]
1140 -- See if any default works, and if so bind the type variable to it
1141 -- If not, add an AmbigErr
1142 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1144 try_default default_tys `thenTc` \ chosen_default_ty ->
1146 -- Bind the type variable and reduce the context, for real this time
1148 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1150 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1151 reduceContext (text "disambig" <+> ppr dicts)
1152 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1153 ASSERT( null frees && null ambigs )
1154 warnDefault dicts chosen_default_ty `thenTc_`
1157 | all isCreturnableClass classes
1158 = -- Default CCall stuff to (); we don't even both to check that () is an
1159 -- instance of CReturnable, because we know it is.
1160 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1161 returnTc EmptyMonoBinds
1163 | otherwise -- No defaults
1164 = complain dicts `thenNF_Tc_`
1165 returnTc EmptyMonoBinds
1168 complain = addAmbigErrs tyVarsOfInst
1169 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1170 tyvar = get_tv (head dicts) -- Should be non-empty
1171 classes = map get_clas dicts
1174 [Aside - why the defaulting mechanism is turned off when
1175 dealing with arguments and results to ccalls.
1177 When typechecking _ccall_s, TcExpr ensures that the external
1178 function is only passed arguments (and in the other direction,
1179 results) of a restricted set of 'native' types. This is
1180 implemented via the help of the pseudo-type classes,
1181 @CReturnable@ (CR) and @CCallable@ (CC.)
1183 The interaction between the defaulting mechanism for numeric
1184 values and CC & CR can be a bit puzzling to the user at times.
1193 What type has 'x' got here? That depends on the default list
1194 in operation, if it is equal to Haskell 98's default-default
1195 of (Integer, Double), 'x' has type Double, since Integer
1196 is not an instance of CR. If the default list is equal to
1197 Haskell 1.4's default-default of (Int, Double), 'x' has type
1200 To try to minimise the potential for surprises here, the
1201 defaulting mechanism is turned off in the presence of
1202 CCallable and CReturnable.
1208 ToDo: for these error messages, should we note the location as coming
1209 from the insts, or just whatever seems to be around in the monad just
1213 genCantGenErr insts -- Can't generalise these Insts
1214 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1215 nest 4 (pprInstsInFull insts)
1218 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1220 addAmbigErr ambig_tv_fn dict
1221 = addInstErrTcM (instLoc dict)
1223 sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
1224 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1226 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1227 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1229 warnDefault dicts default_ty
1230 | not opt_WarnTypeDefaults
1236 msg | length dicts > 1
1237 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1238 $$ pprInstsInFull tidy_dicts
1240 = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1241 ptext SLIT("to type") <+> quotes (ppr default_ty)
1243 (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1246 = addInstErrTcM (instLoc dict)
1248 vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1249 nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
1251 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1254 = addInstErrTcM (instLoc dict)
1256 ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
1258 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1260 -- Used for top-level irreducibles
1261 addTopInstanceErr dict
1262 = addInstErrTcM (instLoc dict)
1264 ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1266 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1268 addNoInstanceErr str givens dict
1269 = addInstErrTcM (instLoc dict) (tidy_env, doc)
1271 doc = vcat [herald <+> quotes (pprInst tidy_dict),
1272 nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
1274 ptext SLIT("Probable fix:"),
1278 herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
1279 unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
1283 | not ambig_overlap = empty
1285 = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
1286 nest 4 (ptext SLIT("depends on the instantiation of") <+>
1287 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
1289 fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
1290 ptext SLIT("to the") <+> str]
1292 fix2 | isTyVarDict dict || ambig_overlap
1295 = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
1297 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1299 -- Checks for the ambiguous case when we have overlapping instances
1300 ambig_overlap | isClassDict dict
1301 = case lookupInstEnv (classInstEnv clas) tys of
1302 NoMatch ambig -> ambig
1306 (clas,tys) = getDictClassTys dict
1308 -- Used for the ...Thetas variants; all top level
1310 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1312 reduceDepthErr n stack
1313 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1314 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1315 nest 4 (pprInstsInFull stack)]
1317 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)