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, isStdClassTyVarDict,
136 isMethodFor, notFunDep,
137 instToId, instBindingRequired, instCanBeGeneralised,
139 getDictClassTys, getIPs,
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 )
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 Maybes ( maybeToBool )
172 %************************************************************************
174 \subsection[tcSimplify-main]{Main entry function}
176 %************************************************************************
178 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
179 the ``don't-squash-consts'' flag set depending on top-level ness. For
180 top level defns we *do* squash constants, so that they stay local to a
181 single defn. This makes things which are inlined more likely to be
182 exportable, because their constants are "inside". Later passes will
183 float them out if poss, after inlinings are sorted out.
188 -> TcTyVarSet -- ``Local'' type variables
189 -- ASSERT: this tyvar set is already zonked
191 -> TcM s (LIE, -- Free
192 TcDictBinds, -- Bindings
193 LIE) -- Remaining wanteds; no dups
195 tcSimplify str local_tvs wanted_lie
196 {- this is just an optimization, and interferes with implicit params,
197 disable it for now. same goes for tcSimplifyAndCheck
198 | isEmptyVarSet local_tvs
199 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
203 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
205 -- Check for non-generalisable insts
207 cant_generalise = filter (not . instCanBeGeneralised) irreds
209 checkTc (null cant_generalise)
210 (genCantGenErr cant_generalise) `thenTc_`
212 -- Check for ambiguous insts.
213 -- You might think these can't happen (I did) because an ambiguous
214 -- inst like (Eq a) will get tossed out with "frees", and eventually
215 -- dealt with by tcSimplifyTop.
216 -- But we can get stuck with
218 -- where "a" is one of the local_tvs, but "b" is unconstrained.
219 -- Then we must yell about the ambiguous b
220 -- But we must only do so if "b" really is unconstrained; so
221 -- we must grab the global tyvars to answer that question
222 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
224 avail_tvs = local_tvs `unionVarSet` global_tvs
225 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
226 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
228 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
232 returnTc (mkLIE frees, binds, mkLIE irreds')
234 -- the idea behind filtering out the dependencies here is that
235 -- they've already served their purpose, and can be reconstructed
236 -- at a later point from the retained class predicates.
237 -- however, there *is* the possibility that a dependency
238 -- out-lives the predicate from which it arose.
239 -- I don't have any examples of this, but if they show up,
240 -- we'd want to consider the possibility of saving the
241 -- dependencies as hidden constraints (i.e. they'd only
242 -- show up in interface files) -- or maybe they'd be useful
243 -- as first class predicates...
244 wanteds = filter notFunDep (lieToList wanted_lie)
247 -- Does not constrain a local tyvar
248 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
249 && null (getIPs inst)
250 = -- if is_top_level then
251 -- FreeIfTautological -- Special case for inference on
252 -- -- top-level defns
256 -- We're infering (not checking) the type, and
257 -- the inst constrains a local type variable
258 | isDict inst = DontReduceUnlessConstant -- Dicts
259 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
262 @tcSimplifyAndCheck@ is similar to the above, except that it checks
263 that there is an empty wanted-set at the end. It may still return
264 some of constant insts, which have to be resolved finally at the end.
269 -> TcTyVarSet -- ``Local'' type variables
270 -- ASSERT: this tyvar set is already zonked
271 -> LIE -- Given; constrain only local tyvars
273 -> TcM s (LIE, -- Free
274 TcDictBinds) -- Bindings
276 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
278 | isEmptyVarSet local_tvs
279 -- This can happen quite legitimately; for example in
280 -- instance Num Int where ...
281 = returnTc (wanted_lie, EmptyMonoBinds)
285 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
287 -- Complain about any irreducible ones
288 mapNF_Tc complain irreds `thenNF_Tc_`
291 returnTc (mkLIE frees, binds)
293 givens = lieToList given_lie
294 -- see comment on wanteds in tcSimplify
295 wanteds = filter notFunDep (lieToList wanted_lie)
296 given_dicts = filter isClassDict givens
299 -- Does not constrain a local tyvar
300 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
301 && (isDict inst || null (getIPs inst))
304 -- When checking against a given signature we always reduce
305 -- until we find a match against something given, or can't reduce
307 = ReduceMe AddToIrreds
309 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
310 addNoInstanceErr str given_dicts dict
313 On the LHS of transformation rules we only simplify methods and constants,
314 getting dictionaries. We want to keep all of them unsimplified, to serve
315 as the available stuff for the RHS of the rule.
317 The same thing is used for specialise pragmas. Consider
320 {-# SPECIALISE f :: Int -> Int #-}
323 The type checker generates a binding like:
325 f_spec = (f :: Int -> Int)
327 and we want to end up with
329 f_spec = _inline_me_ (f Int dNumInt)
331 But that means that we must simplify the Method for f to (f Int dNumInt)!
332 So tcSimplifyToDicts squeezes out all Methods.
335 tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
336 tcSimplifyToDicts wanted_lie
337 = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
339 returnTc (mkLIE irreds, binds)
341 -- see comment on wanteds in tcSimplify
342 -- ZZ waitaminute - doesn't appear that any funDeps should even be here...
343 -- wanteds = filter notFunDep (lieToList wanted_lie)
344 wanteds = lieToList wanted_lie
346 -- Reduce methods and lits only; stop as soon as we get a dictionary
347 try_me inst | isDict inst = DontReduce
348 | otherwise = ReduceMe AddToIrreds
351 The following function partitions a LIE by a predicate defined
352 over `Pred'icates (an unfortunate overloading of terminology!).
353 This means it sometimes has to split up `Methods', in which case
354 a binding is generated.
356 It is used in `with' bindings to extract from the LIE the implicit
357 parameters being bound.
360 partitionPredsOfLIE pred lie
361 = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
362 where insts = lieToList lie
364 -- warning: the term `pred' is overloaded here!
365 partPreds pred (lie1, lie2, binds) inst
366 | maybeToBool maybe_pred
368 returnTc (consLIE inst lie1, lie2, binds)
370 returnTc (lie1, consLIE inst lie2, binds)
371 where maybe_pred = getDictPred_maybe inst
374 -- the assumption is that those satisfying `pred' are being extracted,
375 -- so we leave the method untouched when nothing satisfies `pred'
376 partPreds pred (lie1, lie2, binds1) inst
377 | maybeToBool maybe_theta
378 = if any pred theta then
379 zonkInst inst `thenTc` \ inst' ->
380 tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) ->
381 partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
382 returnTc (lie1 `plusLIE` lie1',
383 lie2 `plusLIE` lie2',
384 binds1 `AndMonoBinds` binds2)
386 returnTc (lie1, consLIE inst lie2, binds1)
387 where maybe_theta = getMethodTheta_maybe inst
388 Just theta = maybe_theta
390 partPreds pred (lie1, lie2, binds) inst
391 = returnTc (lie1, consLIE inst lie2, binds)
395 %************************************************************************
397 \subsection{Data types for the reduction mechanism}
399 %************************************************************************
401 The main control over context reduction is here
405 = ReduceMe -- Try to reduce this
406 NoInstanceAction -- What to do if there's no such instance
408 | DontReduce -- Return as irreducible
410 | DontReduceUnlessConstant -- Return as irreducible unless it can
411 -- be reduced to a constant in one step
413 | Free -- Return as free
415 | FreeIfTautological -- Return as free iff it's tautological;
416 -- if not, return as irreducible
417 -- The FreeIfTautological case is to allow the possibility
418 -- of generating functions with types like
419 -- f :: C Int => Int -> Int
420 -- Here, the C Int isn't a tautology presumably because Int
421 -- isn't an instance of C in this module; but perhaps it will
422 -- be at f's call site(s). Haskell doesn't allow this at
425 data NoInstanceAction
426 = Stop -- Fail; no error message
427 -- (Only used when tautology checking.)
429 | AddToIrreds -- Just add the inst to the irreductible ones; don't
430 -- produce an error message of any kind.
431 -- It might be quite legitimate such as (Eq a)!
438 = (Avails s, -- What's available
439 [Inst], -- Insts for which try_me returned Free
440 [Inst] -- Insts for which try_me returned DontReduce
443 type Avails s = FiniteMap Inst Avail
447 TcId -- The "main Id"; that is, the Id for the Inst that
448 -- caused this avail to be put into the finite map in the first place
449 -- It is this Id that is bound to the RHS.
451 RHS -- The RHS: an expression whose value is that Inst.
452 -- The main Id should be bound to this RHS
454 [TcId] -- Extra Ids that must all be bound to the main Id.
455 -- At the end we generate a list of bindings
456 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
459 = NoRhs -- Used for irreducible dictionaries,
460 -- which are going to be lambda bound, or for those that are
461 -- suppplied as "given" when checking againgst a signature.
463 -- NoRhs is also used for Insts like (CCallable f)
464 -- where no witness is required.
466 | Rhs -- Used when there is a RHS
468 Bool -- True => the RHS simply selects a superclass dictionary
469 -- from a subclass dictionary.
471 -- This is useful info, because superclass selection
472 -- is cheaper than building the dictionary using its dfun,
473 -- and we can sometimes replace the latter with the former
475 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
476 -- an (Ord t) dictionary; then we put an (Eq t) entry in
477 -- the finite map, with an PassiveScSel. Then if the
478 -- the (Eq t) binding is ever *needed* we make it an Rhs
480 [Inst] -- List of Insts that are free in the RHS.
481 -- If the main Id is subsequently needed, we toss this list into
482 -- the needed-inst pool so that we make sure their bindings
483 -- will actually be produced.
485 -- Invariant: these Insts are already in the finite mapping
488 pprAvails avails = vcat (map pprAvail (eltsFM avails))
490 pprAvail (Avail main_id rhs ids)
491 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
493 instance Outputable Avail where
496 pprRhs NoRhs = text "<no rhs>"
497 pprRhs (Rhs rhs b) = ppr rhs
498 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
502 %************************************************************************
504 \subsection[reduce]{@reduce@}
506 %************************************************************************
508 The main entry point for context reduction is @reduceContext@:
511 reduceContext :: SDoc -> (Inst -> WhatToDo)
514 -> TcM s (TcDictBinds,
516 [Inst]) -- Irreducible
518 reduceContext str try_me givens wanteds
520 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
521 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
524 pprTrace "reduceContext" (vcat [
525 text "----------------------",
527 text "given" <+> ppr givens,
528 text "wanted" <+> ppr wanteds,
529 text "----------------------"
532 -- Build the Avail mapping from "givens"
533 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
536 reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
538 -- Extract the bindings from avails
540 binds = foldFM add_bind EmptyMonoBinds avails
542 add_bind _ (Avail main_id rhs ids) binds
543 = foldr add_synonym (add_rhs_bind rhs binds) ids
545 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
546 add_rhs_bind other binds = binds
548 -- Add the trivial {x = y} bindings
549 -- The main Id can end up in the list when it's first added passively
550 -- and then activated, so we have to filter it out. A bit of a hack.
552 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
556 pprTrace ("reduceContext end") (vcat [
557 text "----------------------",
559 text "given" <+> ppr givens,
560 text "wanted" <+> ppr wanteds,
562 text "avails" <+> pprAvails avails,
563 text "frees" <+> ppr frees,
564 text "irreds" <+> ppr irreds,
565 text "----------------------"
568 returnTc (binds, frees, irreds)
571 The main context-reduction function is @reduce@. Here's its game plan.
574 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
575 -- along with its depth
576 -> (Inst -> WhatToDo)
579 -> TcM s (RedState s)
583 try_me: given an inst, this function returns
585 DontReduce return this in "irreds"
586 Free return this in "frees"
588 wanteds: The list of insts to reduce
589 state: An accumulating parameter of type RedState
590 that contains the state of the algorithm
592 It returns a RedState.
594 The (n,stack) pair is just used for error reporting.
595 n is always the depth of the stack.
596 The stack is the stack of Insts being reduced: to produce X
597 I had to produce Y, to produce Y I had to produce Z, and so on.
600 reduceList (n,stack) try_me wanteds state
601 | n > opt_MaxContextReductionDepth
602 = failWithTc (reduceDepthErr n stack)
608 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
613 go [] state = returnTc state
614 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
617 -- Base case: we're done!
618 reduce stack try_me wanted state@(avails, frees, irreds)
619 -- It's the same as an existing inst, or a superclass thereof
620 | wanted `elemFM` avails
621 = returnTc (activate avails wanted, frees, irreds)
624 = case try_me wanted of {
626 ReduceMe no_instance_action -> -- It should be reduced
627 lookupInst wanted `thenNF_Tc` \ lookup_result ->
628 case lookup_result of
629 GenInst wanteds' rhs -> use_instance wanteds' rhs
630 SimpleInst rhs -> use_instance [] rhs
632 NoInstance -> -- No such instance!
633 case no_instance_action of
635 AddToIrreds -> add_to_irreds
637 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
638 -- First, see if the inst can be reduced to a constant in one step
639 lookupInst wanted `thenNF_Tc` \ lookup_result ->
640 case lookup_result of
641 SimpleInst rhs -> use_instance [] rhs
642 other -> add_to_frees
647 FreeIfTautological -> -- It's free and this is a top level binding, so
648 -- check whether it's a tautology or not
650 add_to_irreds -- If tautology trial fails, add to irreds
652 -- If tautology succeeds, just add to frees
653 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
654 returnTc (avails, wanted:frees, irreds))
659 DontReduce -> add_to_irreds
662 DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
663 -- See if the inst can be reduced to a constant in one step
664 lookupInst wanted `thenNF_Tc` \ lookup_result ->
665 case lookup_result of
666 SimpleInst rhs -> use_instance [] rhs
667 other -> add_to_irreds
670 -- The three main actions
672 avails' = addFree avails wanted
673 -- Add the thing to the avails set so any identical Insts
674 -- will be commoned up with it right here
676 returnTc (avails', wanted:frees, irreds)
678 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
679 returnTc (avails', frees, wanted:irreds)
681 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
682 reduceList stack try_me wanteds' (avails', frees, irreds)
685 -- The try-me to use when trying to identify tautologies
686 -- It blunders on reducing as much as possible
687 try_me_taut inst = ReduceMe Stop -- No error recovery
692 activate :: Avails s -> Inst -> Avails s
693 -- Activate the binding for Inst, ensuring that a binding for the
694 -- wanted Inst will be generated.
695 -- (Activate its parent if necessary, recursively).
696 -- Precondition: the Inst is in Avails already
698 activate avails wanted
699 | not (instBindingRequired wanted)
703 = case lookupFM avails wanted of
705 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
706 foldl activate avails' insts -- Activate anything it needs
708 avails' = addToFM avails wanted avail'
709 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
711 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
712 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
714 Nothing -> panic "activate"
716 wanted_id = instToId wanted
718 addWanted avails wanted rhs_expr
719 = ASSERT( not (wanted `elemFM` avails) )
720 returnNF_Tc (addToFM avails wanted avail)
721 -- NB: we don't add the thing's superclasses too!
722 -- Why not? Because addWanted is used when we've successfully used an
723 -- instance decl to reduce something; e.g.
724 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
725 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
726 -- If we put the superclasses of "d" in avails, then we might end up
727 -- expressing "d1" in terms of "d", which would be a disaster.
729 avail = Avail (instToId wanted) rhs []
731 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
734 addFree :: Avails s -> Inst -> (Avails s)
735 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
736 -- to avails, so that any other equal Insts will be commoned up right
737 -- here rather than also being tossed upstairs. This is really just
738 -- an optimisation, and perhaps it is more trouble that it is worth,
739 -- as the following comments show!
741 -- NB1: do *not* add superclasses. If we have
744 -- but a is not bound here, then we *don't* want to derive
745 -- dn from df here lest we lose sharing.
747 -- NB2: do *not* add the Inst to avails at all if it's a method.
748 -- The following situation shows why this is bad:
749 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
750 -- From an application (truncate f i) we get
751 -- t1 = truncate at f
753 -- If we have also have a secon occurrence of truncate, we get
754 -- t3 = truncate at f
756 -- When simplifying with i,f free, we might still notice that
757 -- t1=t3; but alas, the binding for t2 (which mentions t1)
758 -- will continue to float out!
759 -- Solution: never put methods in avail till they are captured
760 -- in which case addFree isn't used
762 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
765 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
766 addGiven avails given
767 = -- ASSERT( not (given `elemFM` avails) )
768 -- This assertion isn't necessarily true. It's permitted
769 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
770 -- and when typechecking instance decls we generate redundant "givens" too.
771 -- addAvail avails given avail
772 addAvail avails given avail `thenNF_Tc` \av ->
773 zonkInst given `thenNF_Tc` \given' ->
776 avail = Avail (instToId given) NoRhs []
778 addAvail avails wanted avail
779 = addSuperClasses (addToFM avails wanted avail) wanted
781 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
782 -- Add all the superclasses of the Inst to Avails
783 -- Invariant: the Inst is already in Avails.
785 addSuperClasses avails dict
786 | not (isClassDict dict)
789 | otherwise -- It is a dictionary
790 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
792 (clas, tys) = getDictClassTys dict
794 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
795 sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
797 add_sc avails ((super_clas, super_tys), sc_sel)
798 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
800 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
803 case lookupFM avails super_dict of
805 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
806 -- Already there, but not as a superclass selector
807 -- No need to look at its superclasses; since it's there
808 -- already they must be already in avails
809 -- However, we must remember to activate the dictionary
810 -- from which it is (now) generated
811 returnNF_Tc (activate avails' dict)
813 avails' = addToFM avails super_dict avail
814 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
816 Just (Avail _ _ _) -> returnNF_Tc avails
817 -- Already there; no need to do anything
820 -- Not there at all, so add it, and its superclasses
821 addAvail avails super_dict avail
823 avail = Avail (instToId super_dict)
824 (PassiveScSel sc_sel_rhs [dict])
828 %************************************************************************
830 \subsection[simple]{@Simple@ versions}
832 %************************************************************************
834 Much simpler versions when there are no bindings to make!
836 @tcSimplifyThetas@ simplifies class-type constraints formed by
837 @deriving@ declarations and when specialising instances. We are
838 only interested in the simplified bunch of class/type constraints.
840 It simplifies to constraints of the form (C a b c) where
841 a,b,c are type variables. This is required for the context of
842 instance declarations.
845 tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
846 -> ClassContext -- Wanted
847 -> TcM s ClassContext -- Needed
849 tcSimplifyThetas inst_mapper wanteds
850 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
852 -- For multi-param Haskell, check that the returned dictionaries
853 -- don't have any of the form (C Int Bool) for which
854 -- we expect an instance here
855 -- For Haskell 98, check that all the constraints are of the form C a,
856 -- where a is a type variable
857 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
858 isEmptyVarSet (tyVarsOfTypes tys)]
859 | otherwise = [ct | ct@(clas,tys) <- irreds,
860 not (all isTyVarTy tys)]
862 if null bad_guys then
865 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
869 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
870 used with \tr{default} declarations. We are only interested in
871 whether it worked or not.
874 tcSimplifyCheckThetas :: ClassContext -- Given
875 -> ClassContext -- Wanted
878 tcSimplifyCheckThetas givens wanteds
879 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
883 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
889 type AvailsSimple = FiniteMap (Class,[Type]) Bool
890 -- True => irreducible
891 -- False => given, or can be derived from a given or from an irreducible
893 reduceSimple :: (Class -> InstEnv)
894 -> ClassContext -- Given
895 -> ClassContext -- Wanted
896 -> NF_TcM s ClassContext -- Irreducible
898 reduceSimple inst_mapper givens wanteds
899 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
900 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
902 givens_fm = foldl addNonIrred emptyFM givens
904 reduce_simple :: (Int,ClassContext) -- Stack
905 -> (Class -> InstEnv)
908 -> NF_TcM s AvailsSimple
910 reduce_simple (n,stack) inst_mapper avails wanteds
913 go avails [] = returnNF_Tc avails
914 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
917 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
918 | wanted `elemFM` givens
922 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
925 Nothing -> returnNF_Tc (addIrred givens wanted)
926 Just theta -> reduce_simple stack inst_mapper (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 s (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 s 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 -- see comment on wanteds in tcSimplify
1086 wanteds = filter notFunDep (lieToList wanted_lie)
1087 try_me inst = ReduceMe AddToIrreds
1089 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1091 complain d | not (null (getIPs d)) = addTopIPErr d
1092 | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1093 | otherwise = addAmbigErr tyVarsOfInst d
1095 get_tv d = case getDictClassTys d of
1096 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1097 get_clas d = case getDictClassTys d of
1098 (clas, [ty]) -> clas
1101 @disambigOne@ assumes that its arguments dictionaries constrain all
1102 the same type variable.
1104 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1105 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1106 the most common use of defaulting is code like:
1108 _ccall_ foo `seqPrimIO` bar
1110 Since we're not using the result of @foo@, the result if (presumably)
1114 disambigGroup :: [Inst] -- All standard classes of form (C a)
1115 -> TcM s TcDictBinds
1118 | any isNumericClass classes -- Guaranteed all standard classes
1119 -- see comment at the end of function for reasons as to
1120 -- why the defaulting mechanism doesn't apply to groups that
1121 -- include CCallable or CReturnable dicts.
1122 && not (any isCcallishClass classes)
1123 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1124 -- SO, TRY DEFAULT TYPES IN ORDER
1126 -- Failure here is caused by there being no type in the
1127 -- default list which can satisfy all the ambiguous classes.
1128 -- For example, if Real a is reqd, but the only type in the
1129 -- default list is Int.
1130 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1132 try_default [] -- No defaults work, so fail
1135 try_default (default_ty : default_tys)
1136 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1137 -- default_tys instead
1138 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1141 thetas = classes `zip` repeat [default_ty]
1143 -- See if any default works, and if so bind the type variable to it
1144 -- If not, add an AmbigErr
1145 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1147 try_default default_tys `thenTc` \ chosen_default_ty ->
1149 -- Bind the type variable and reduce the context, for real this time
1151 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1153 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1154 reduceContext (text "disambig" <+> ppr dicts)
1155 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1156 ASSERT( null frees && null ambigs )
1157 warnDefault dicts chosen_default_ty `thenTc_`
1160 | all isCreturnableClass classes
1161 = -- Default CCall stuff to (); we don't even both to check that () is an
1162 -- instance of CReturnable, because we know it is.
1163 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1164 returnTc EmptyMonoBinds
1166 | otherwise -- No defaults
1167 = complain dicts `thenNF_Tc_`
1168 returnTc EmptyMonoBinds
1171 complain = addAmbigErrs tyVarsOfInst
1172 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1173 tyvar = get_tv (head dicts) -- Should be non-empty
1174 classes = map get_clas dicts
1177 [Aside - why the defaulting mechanism is turned off when
1178 dealing with arguments and results to ccalls.
1180 When typechecking _ccall_s, TcExpr ensures that the external
1181 function is only passed arguments (and in the other direction,
1182 results) of a restricted set of 'native' types. This is
1183 implemented via the help of the pseudo-type classes,
1184 @CReturnable@ (CR) and @CCallable@ (CC.)
1186 The interaction between the defaulting mechanism for numeric
1187 values and CC & CR can be a bit puzzling to the user at times.
1196 What type has 'x' got here? That depends on the default list
1197 in operation, if it is equal to Haskell 98's default-default
1198 of (Integer, Double), 'x' has type Double, since Integer
1199 is not an instance of CR. If the default list is equal to
1200 Haskell 1.4's default-default of (Int, Double), 'x' has type
1203 To try to minimise the potential for surprises here, the
1204 defaulting mechanism is turned off in the presence of
1205 CCallable and CReturnable.
1211 ToDo: for these error messages, should we note the location as coming
1212 from the insts, or just whatever seems to be around in the monad just
1216 genCantGenErr insts -- Can't generalise these Insts
1217 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1218 nest 4 (pprInstsInFull insts)
1221 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1223 addAmbigErr ambig_tv_fn dict
1224 = addInstErrTcM (instLoc dict)
1226 sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
1227 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1229 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1230 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1232 warnDefault dicts default_ty
1233 | not opt_WarnTypeDefaults
1239 msg | length dicts > 1
1240 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1241 $$ pprInstsInFull tidy_dicts
1243 = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1244 ptext SLIT("to type") <+> quotes (ppr default_ty)
1246 (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1249 = addInstErrTcM (instLoc dict)
1251 vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1252 nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
1254 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1257 = addInstErrTcM (instLoc dict)
1259 ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
1261 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1263 -- Used for top-level irreducibles
1264 addTopInstanceErr dict
1265 = addInstErrTcM (instLoc dict)
1267 ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1269 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1271 addNoInstanceErr str givens dict
1272 = addInstErrTcM (instLoc dict)
1274 sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1275 nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1277 ptext SLIT("Probable cause:") <+>
1278 vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1279 ptext SLIT("in") <+> str],
1280 if isClassDict dict && all_tyvars then empty else
1281 ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1284 all_tyvars = all isTyVarTy tys
1285 (_, tys) = getDictClassTys dict
1286 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1288 -- Used for the ...Thetas variants; all top level
1290 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1292 reduceDepthErr n stack
1293 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1294 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1295 nest 4 (pprInstsInFull stack)]
1297 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)