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,
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, isStdClassTyVarDict, isMethodFor,
136 instToId, instBindingRequired, instCanBeGeneralised,
138 instLoc, getDictClassTys,
139 pprInst, zonkInst, tidyInst, tidyInsts,
140 Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
143 import TcEnv ( tcGetGlobalTyVars )
144 import TcType ( TcType, TcTyVarSet, typeToTcType )
145 import TcUnify ( unifyTauTy )
147 import Bag ( bagToList )
148 import Class ( Class, classBigSig, classInstEnv )
149 import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
151 import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
152 isTyVarTy, splitSigmaTy, tyVarsOfTypes
154 import InstEnv ( InstEnv )
155 import Subst ( mkTopTyVarSubst, substTheta )
156 import PprType ( pprConstraint )
157 import TysWiredIn ( unitTy )
160 import BasicTypes ( TopLevelFlag(..) )
161 import CmdLineOpts ( opt_GlasgowExts )
164 import List ( partition )
168 %************************************************************************
170 \subsection[tcSimplify-main]{Main entry function}
172 %************************************************************************
174 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
175 the ``don't-squash-consts'' flag set depending on top-level ness. For
176 top level defns we *do* squash constants, so that they stay local to a
177 single defn. This makes things which are inlined more likely to be
178 exportable, because their constants are "inside". Later passes will
179 float them out if poss, after inlinings are sorted out.
185 -> TcTyVarSet -- ``Local'' type variables
186 -- ASSERT: this tyvar set is already zonked
188 -> TcM s (LIE, -- Free
189 TcDictBinds, -- Bindings
190 LIE) -- Remaining wanteds; no dups
192 tcSimplify str top_lvl local_tvs wanted_lie
193 | isEmptyVarSet local_tvs
194 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
197 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
199 -- Check for non-generalisable insts
201 cant_generalise = filter (not . instCanBeGeneralised) irreds
203 checkTc (null cant_generalise)
204 (genCantGenErr cant_generalise) `thenTc_`
206 -- Check for ambiguous insts.
207 -- You might think these can't happen (I did) because an ambiguous
208 -- inst like (Eq a) will get tossed out with "frees", and eventually
209 -- dealt with by tcSimplifyTop.
210 -- But we can get stuck with
212 -- where "a" is one of the local_tvs, but "b" is unconstrained.
213 -- Then we must yell about the ambiguous b
214 -- But we must only do so if "b" really is unconstrained; so
215 -- we must grab the global tyvars to answer that question
216 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
218 avail_tvs = local_tvs `unionVarSet` global_tvs
219 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
220 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
222 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
226 returnTc (mkLIE frees, binds, mkLIE irreds')
228 wanteds = bagToList wanted_lie
231 -- Does not constrain a local tyvar
232 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
233 = -- if is_top_level then
234 -- FreeIfTautological -- Special case for inference on
235 -- -- top-level defns
239 -- We're infering (not checking) the type, and
240 -- the inst constrains a local type variable
241 | isDict inst = DontReduce -- Dicts
242 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
245 @tcSimplifyAndCheck@ is similar to the above, except that it checks
246 that there is an empty wanted-set at the end. It may still return
247 some of constant insts, which have to be resolved finally at the end.
252 -> TcTyVarSet -- ``Local'' type variables
253 -- ASSERT: this tyvar set is already zonked
254 -> LIE -- Given; constrain only local tyvars
256 -> TcM s (LIE, -- Free
257 TcDictBinds) -- Bindings
259 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
260 | isEmptyVarSet local_tvs
261 -- This can happen quite legitimately; for example in
262 -- instance Num Int where ...
263 = returnTc (wanted_lie, EmptyMonoBinds)
266 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
268 -- Complain about any irreducible ones
269 mapNF_Tc complain irreds `thenNF_Tc_`
272 returnTc (mkLIE frees, binds)
274 givens = bagToList given_lie
275 wanteds = bagToList wanted_lie
276 given_dicts = filter isDict givens
279 -- Does not constrain a local tyvar
280 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
283 -- When checking against a given signature we always reduce
284 -- until we find a match against something given, or can't reduce
286 = ReduceMe AddToIrreds
288 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
289 addNoInstanceErr str given_dicts dict
292 On the LHS of transformation rules we only simplify methods and constants,
293 getting dictionaries. We want to keep all of them unsimplified, to serve
294 as the available stuff for the RHS of the rule.
296 The same thing is used for specialise pragmas. Consider
299 {-# SPECIALISE f :: Int -> Int #-}
302 The type checker generates a binding like:
304 f_spec = (f :: Int -> Int)
306 and we want to end up with
308 f_spec = _inline_me_ (f Int dNumInt)
310 But that means that we must simplify the Method for f to (f Int dNumInt)!
311 So tcSimplifyToDicts squeezes out all Methods.
314 tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
315 tcSimplifyToDicts wanted_lie
316 = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
318 returnTc (mkLIE irreds, binds)
320 wanteds = bagToList wanted_lie
322 -- Reduce methods and lits only; stop as soon as we get a dictionary
323 try_me inst | isDict inst = DontReduce
324 | otherwise = ReduceMe AddToIrreds
329 %************************************************************************
331 \subsection{Data types for the reduction mechanism}
333 %************************************************************************
335 The main control over context reduction is here
339 = ReduceMe -- Try to reduce this
340 NoInstanceAction -- What to do if there's no such instance
342 | DontReduce -- Return as irreducible
344 | Free -- Return as free
346 | FreeIfTautological -- Return as free iff it's tautological;
347 -- if not, return as irreducible
348 -- The FreeIfTautological case is to allow the possibility
349 -- of generating functions with types like
350 -- f :: C Int => Int -> Int
351 -- Here, the C Int isn't a tautology presumably because Int
352 -- isn't an instance of C in this module; but perhaps it will
353 -- be at f's call site(s). Haskell doesn't allow this at
356 data NoInstanceAction
357 = Stop -- Fail; no error message
358 -- (Only used when tautology checking.)
360 | AddToIrreds -- Just add the inst to the irreductible ones; don't
361 -- produce an error message of any kind.
362 -- It might be quite legitimate such as (Eq a)!
369 = (Avails s, -- What's available
370 [Inst], -- Insts for which try_me returned Free
371 [Inst] -- Insts for which try_me returned DontReduce
374 type Avails s = FiniteMap Inst Avail
378 TcId -- The "main Id"; that is, the Id for the Inst that
379 -- caused this avail to be put into the finite map in the first place
380 -- It is this Id that is bound to the RHS.
382 RHS -- The RHS: an expression whose value is that Inst.
383 -- The main Id should be bound to this RHS
385 [TcId] -- Extra Ids that must all be bound to the main Id.
386 -- At the end we generate a list of bindings
387 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
390 = NoRhs -- Used for irreducible dictionaries,
391 -- which are going to be lambda bound, or for those that are
392 -- suppplied as "given" when checking againgst a signature.
394 -- NoRhs is also used for Insts like (CCallable f)
395 -- where no witness is required.
397 | Rhs -- Used when there is a RHS
399 Bool -- True => the RHS simply selects a superclass dictionary
400 -- from a subclass dictionary.
402 -- This is useful info, because superclass selection
403 -- is cheaper than building the dictionary using its dfun,
404 -- and we can sometimes replace the latter with the former
406 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
407 -- an (Ord t) dictionary; then we put an (Eq t) entry in
408 -- the finite map, with an PassiveScSel. Then if the
409 -- the (Eq t) binding is ever *needed* we make it an Rhs
411 [Inst] -- List of Insts that are free in the RHS.
412 -- If the main Id is subsequently needed, we toss this list into
413 -- the needed-inst pool so that we make sure their bindings
414 -- will actually be produced.
416 -- Invariant: these Insts are already in the finite mapping
419 pprAvails avails = vcat (map pp (eltsFM avails))
421 pp (Avail main_id rhs ids)
422 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
424 pprRhs NoRhs = text "<no rhs>"
425 pprRhs (Rhs rhs b) = ppr rhs
426 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
430 %************************************************************************
432 \subsection[reduce]{@reduce@}
434 %************************************************************************
436 The main entry point for context reduction is @reduceContext@:
439 reduceContext :: SDoc -> (Inst -> WhatToDo)
442 -> TcM s (TcDictBinds,
444 [Inst]) -- Irreducible
446 reduceContext str try_me givens wanteds
448 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
449 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
452 pprTrace "reduceContext" (vcat [
453 text "----------------------",
455 text "given" <+> ppr givens,
456 text "wanted" <+> ppr wanteds,
457 text "----------------------"
460 -- Build the Avail mapping from "givens"
461 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
464 reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
466 -- Extract the bindings from avails
468 binds = foldFM add_bind EmptyMonoBinds avails
470 add_bind _ (Avail main_id rhs ids) binds
471 = foldr add_synonym (add_rhs_bind rhs binds) ids
473 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
474 add_rhs_bind other binds = binds
476 -- Add the trivial {x = y} bindings
477 -- The main Id can end up in the list when it's first added passively
478 -- and then activated, so we have to filter it out. A bit of a hack.
480 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
484 pprTrace ("reduceContext end") (vcat [
485 text "----------------------",
487 text "given" <+> ppr givens,
488 text "wanted" <+> ppr wanteds,
490 text "avails" <+> pprAvails avails,
491 text "irreds" <+> ppr irreds,
492 text "----------------------"
495 returnTc (binds, frees, irreds)
498 The main context-reduction function is @reduce@. Here's its game plan.
501 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
502 -- along with its depth
503 -> (Inst -> WhatToDo)
506 -> TcM s (RedState s)
510 try_me: given an inst, this function returns
512 DontReduce return this in "irreds"
513 Free return this in "frees"
515 wanteds: The list of insts to reduce
516 state: An accumulating parameter of type RedState
517 that contains the state of the algorithm
519 It returns a RedState.
521 The (n,stack) pair is just used for error reporting.
522 n is always the depth of the stack.
523 The stack is the stack of Insts being reduced: to produce X
524 I had to produce Y, to produce Y I had to produce Z, and so on.
527 reduceList (n,stack) try_me wanteds state
528 | n > opt_MaxContextReductionDepth
529 = failWithTc (reduceDepthErr n stack)
535 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
540 go [] state = returnTc state
541 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
544 -- Base case: we're done!
545 reduce stack try_me wanted state@(avails, frees, irreds)
546 -- It's the same as an existing inst, or a superclass thereof
547 | wanted `elemFM` avails
548 = returnTc (activate avails wanted, frees, irreds)
551 = case try_me wanted of {
553 ReduceMe no_instance_action -> -- It should be reduced
554 lookupInst wanted `thenNF_Tc` \ lookup_result ->
555 case lookup_result of
556 GenInst wanteds' rhs -> use_instance wanteds' rhs
557 SimpleInst rhs -> use_instance [] rhs
559 NoInstance -> -- No such instance!
560 case no_instance_action of
562 AddToIrreds -> add_to_irreds
564 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
565 -- First, see if the inst can be reduced to a constant in one step
566 lookupInst wanted `thenNF_Tc` \ lookup_result ->
567 case lookup_result of
568 SimpleInst rhs -> use_instance [] rhs
569 other -> add_to_frees
574 FreeIfTautological -> -- It's free and this is a top level binding, so
575 -- check whether it's a tautology or not
577 add_to_irreds -- If tautology trial fails, add to irreds
579 -- If tautology succeeds, just add to frees
580 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
581 returnTc (avails, wanted:frees, irreds))
585 DontReduce -> -- It's irreducible (or at least should not be reduced)
586 -- See if the inst can be reduced to a constant in one step
587 lookupInst wanted `thenNF_Tc` \ lookup_result ->
588 case lookup_result of
589 SimpleInst rhs -> use_instance [] rhs
590 other -> add_to_irreds
593 -- The three main actions
595 avails' = addFree avails wanted
596 -- Add the thing to the avails set so any identical Insts
597 -- will be commoned up with it right here
599 returnTc (avails', wanted:frees, irreds)
601 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
602 returnTc (avails', frees, wanted:irreds)
604 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
605 reduceList stack try_me wanteds' (avails', frees, irreds)
608 -- The try-me to use when trying to identify tautologies
609 -- It blunders on reducing as much as possible
610 try_me_taut inst = ReduceMe Stop -- No error recovery
615 activate :: Avails s -> Inst -> Avails s
616 -- Activate the binding for Inst, ensuring that a binding for the
617 -- wanted Inst will be generated.
618 -- (Activate its parent if necessary, recursively).
619 -- Precondition: the Inst is in Avails already
621 activate avails wanted
622 | not (instBindingRequired wanted)
626 = case lookupFM avails wanted of
628 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
629 foldl activate avails' insts -- Activate anything it needs
631 avails' = addToFM avails wanted avail'
632 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
634 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
635 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
637 Nothing -> panic "activate"
639 wanted_id = instToId wanted
641 addWanted avails wanted rhs_expr
642 = ASSERT( not (wanted `elemFM` avails) )
643 returnNF_Tc (addToFM avails wanted avail)
644 -- NB: we don't add the thing's superclasses too!
645 -- Why not? Because addWanted is used when we've successfully used an
646 -- instance decl to reduce something; e.g.
647 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
648 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
649 -- If we put the superclasses of "d" in avails, then we might end up
650 -- expressing "d1" in terms of "d", which would be a disaster.
652 avail = Avail (instToId wanted) rhs []
654 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
657 addFree :: Avails s -> Inst -> (Avails s)
658 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
659 -- to avails, so that any other equal Insts will be commoned up right
660 -- here rather than also being tossed upstairs. This is really just
661 -- an optimisation, and perhaps it is more trouble that it is worth,
662 -- as the following comments show!
664 -- NB1: do *not* add superclasses. If we have
667 -- but a is not bound here, then we *don't* want to derive
668 -- dn from df here lest we lose sharing.
670 -- NB2: do *not* add the Inst to avails at all if it's a method.
671 -- The following situation shows why this is bad:
672 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
673 -- From an application (truncate f i) we get
674 -- t1 = truncate at f
676 -- If we have also have a secon occurrence of truncate, we get
677 -- t3 = truncate at f
679 -- When simplifying with i,f free, we might still notice that
680 -- t1=t3; but alas, the binding for t2 (which mentions t1)
681 -- will continue to float out!
682 -- Solution: never put methods in avail till they are captured
683 -- in which case addFree isn't used
685 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
688 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
689 addGiven avails given
690 = -- ASSERT( not (given `elemFM` avails) )
691 -- This assertion isn't necessarily true. It's permitted
692 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
693 -- and when typechecking instance decls we generate redundant "givens" too.
694 addAvail avails given avail
696 avail = Avail (instToId given) NoRhs []
698 addAvail avails wanted avail
699 = addSuperClasses (addToFM avails wanted avail) wanted
701 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
702 -- Add all the superclasses of the Inst to Avails
703 -- Invariant: the Inst is already in Avails.
705 addSuperClasses avails dict
709 | otherwise -- It is a dictionary
710 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
712 (clas, tys) = getDictClassTys dict
714 (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
715 sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
717 add_sc avails ((super_clas, super_tys), sc_sel)
718 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
720 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
723 case lookupFM avails super_dict of
725 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
726 -- Already there, but not as a superclass selector
727 -- No need to look at its superclasses; since it's there
728 -- already they must be already in avails
729 -- However, we must remember to activate the dictionary
730 -- from which it is (now) generated
731 returnNF_Tc (activate avails' dict)
733 avails' = addToFM avails super_dict avail
734 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
736 Just (Avail _ _ _) -> returnNF_Tc avails
737 -- Already there; no need to do anything
740 -- Not there at all, so add it, and its superclasses
741 addAvail avails super_dict avail
743 avail = Avail (instToId super_dict)
744 (PassiveScSel sc_sel_rhs [dict])
748 %************************************************************************
750 \subsection[simple]{@Simple@ versions}
752 %************************************************************************
754 Much simpler versions when there are no bindings to make!
756 @tcSimplifyThetas@ simplifies class-type constraints formed by
757 @deriving@ declarations and when specialising instances. We are
758 only interested in the simplified bunch of class/type constraints.
760 It simplifies to constraints of the form (C a b c) where
761 a,b,c are type variables. This is required for the context of
762 instance declarations.
765 tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
766 -> ThetaType -- Wanted
767 -> TcM s ThetaType -- Needed
769 tcSimplifyThetas inst_mapper wanteds
770 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
772 -- For multi-param Haskell, check that the returned dictionaries
773 -- don't have any of the form (C Int Bool) for which
774 -- we expect an instance here
775 -- For Haskell 98, check that all the constraints are of the form C a,
776 -- where a is a type variable
777 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
778 isEmptyVarSet (tyVarsOfTypes tys)]
779 | otherwise = [ct | ct@(clas,tys) <- irreds,
780 not (all isTyVarTy tys)]
782 if null bad_guys then
785 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
789 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
790 used with \tr{default} declarations. We are only interested in
791 whether it worked or not.
794 tcSimplifyCheckThetas :: ThetaType -- Given
795 -> ThetaType -- Wanted
798 tcSimplifyCheckThetas givens wanteds
799 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
803 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
809 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
810 -- True => irreducible
811 -- False => given, or can be derived from a given or from an irreducible
813 reduceSimple :: (Class -> InstEnv)
814 -> ThetaType -- Given
815 -> ThetaType -- Wanted
816 -> NF_TcM s ThetaType -- Irreducible
818 reduceSimple inst_mapper givens wanteds
819 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
820 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
822 givens_fm = foldl addNonIrred emptyFM givens
824 reduce_simple :: (Int,ThetaType) -- Stack
825 -> (Class -> InstEnv)
828 -> NF_TcM s AvailsSimple
830 reduce_simple (n,stack) inst_mapper avails wanteds
833 go avails [] = returnNF_Tc avails
834 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
837 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
838 | wanted `elemFM` givens
842 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
845 Nothing -> returnNF_Tc (addIrred givens wanted)
846 Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
848 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
850 = addSCs (addToFM givens ct True) ct
852 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
853 addNonIrred givens ct
854 = addSCs (addToFM givens ct False) ct
856 addSCs givens ct@(clas,tys)
857 = foldl add givens sc_theta
859 (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
860 sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
862 add givens ct = case lookupFM givens ct of
863 Nothing -> -- Add it and its superclasses
864 addSCs (addToFM givens ct False) ct
866 Just True -> -- Set its flag to False; superclasses already done
867 addToFM givens ct False
869 Just False -> -- Already done
874 %************************************************************************
876 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
878 %************************************************************************
880 When doing a binding group, we may have @Insts@ of local functions.
881 For example, we might have...
883 let f x = x + 1 -- orig local function (overloaded)
884 f.1 = f Int -- two instances of f
889 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
890 where @f@ is in scope; those @Insts@ must certainly not be passed
891 upwards towards the top-level. If the @Insts@ were binding-ified up
892 there, they would have unresolvable references to @f@.
894 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
895 For each method @Inst@ in the @init_lie@ that mentions one of the
896 @Ids@, we create a binding. We return the remaining @Insts@ (in an
897 @LIE@), as well as the @HsBinds@ generated.
900 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
902 bindInstsOfLocalFuns init_lie local_ids
903 | null overloaded_ids || null lie_for_here
905 = returnTc (init_lie, EmptyMonoBinds)
908 = reduceContext (text "bindInsts" <+> ppr local_ids)
909 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
910 ASSERT( null irreds )
911 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
913 overloaded_ids = filter is_overloaded local_ids
914 is_overloaded id = case splitSigmaTy (idType id) of
915 (_, theta, _) -> not (null theta)
917 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
918 -- so it's worth building a set, so that
919 -- lookup (in isMethodFor) is faster
921 -- No sense in repeatedly zonking lots of
922 -- constant constraints so filter them out here
923 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
925 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
930 %************************************************************************
932 \section[Disambig]{Disambiguation of overloading}
934 %************************************************************************
937 If a dictionary constrains a type variable which is
940 not mentioned in the environment
942 and not mentioned in the type of the expression
944 then it is ambiguous. No further information will arise to instantiate
945 the type variable; nor will it be generalised and turned into an extra
946 parameter to a function.
948 It is an error for this to occur, except that Haskell provided for
949 certain rules to be applied in the special case of numeric types.
954 at least one of its classes is a numeric class, and
956 all of its classes are numeric or standard
958 then the type variable can be defaulted to the first type in the
959 default-type list which is an instance of all the offending classes.
961 So here is the function which does the work. It takes the ambiguous
962 dictionaries and either resolves them (producing bindings) or
963 complains. It works by splitting the dictionary list by type
964 variable, and using @disambigOne@ to do the real business.
967 @tcSimplifyTop@ is called once per module to simplify
968 all the constant and ambiguous Insts.
971 tcSimplifyTop :: LIE -> TcM s TcDictBinds
972 tcSimplifyTop wanted_lie
973 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
977 -- All the non-std ones are definite errors
978 (stds, non_stds) = partition isStdClassTyVarDict irreds
981 -- Group by type variable
982 std_groups = equivClasses cmp_by_tyvar stds
984 -- Pick the ones which its worth trying to disambiguate
985 (std_oks, std_bads) = partition worth_a_try std_groups
986 -- Have a try at disambiguation
987 -- if the type variable isn't bound
988 -- up with one of the non-standard classes
989 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
990 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
992 -- Collect together all the bad guys
993 bad_guys = non_stds ++ concat std_bads
996 -- Disambiguate the ones that look feasible
997 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
999 -- And complain about the ones that don't
1000 mapNF_Tc complain bad_guys `thenNF_Tc_`
1002 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1004 wanteds = bagToList wanted_lie
1005 try_me inst = ReduceMe AddToIrreds
1007 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1009 complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1010 | otherwise = addAmbigErr tyVarsOfInst d
1012 get_tv d = case getDictClassTys d of
1013 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1014 get_clas d = case getDictClassTys d of
1015 (clas, [ty]) -> clas
1018 @disambigOne@ assumes that its arguments dictionaries constrain all
1019 the same type variable.
1021 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1022 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1023 the most common use of defaulting is code like:
1025 _ccall_ foo `seqPrimIO` bar
1027 Since we're not using the result of @foo@, the result if (presumably)
1031 disambigGroup :: [Inst] -- All standard classes of form (C a)
1032 -> TcM s TcDictBinds
1035 | any isNumericClass classes -- Guaranteed all standard classes
1036 -- see comment at the end of function for reasons as to
1037 -- why the defaulting mechanism doesn't apply to groups that
1038 -- include CCallable or CReturnable dicts.
1039 && not (any isCcallishClass classes)
1040 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1041 -- SO, TRY DEFAULT TYPES IN ORDER
1043 -- Failure here is caused by there being no type in the
1044 -- default list which can satisfy all the ambiguous classes.
1045 -- For example, if Real a is reqd, but the only type in the
1046 -- default list is Int.
1047 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1049 try_default [] -- No defaults work, so fail
1052 try_default (default_ty : default_tys)
1053 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1054 -- default_tys instead
1055 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1058 thetas = classes `zip` repeat [default_ty]
1060 -- See if any default works, and if so bind the type variable to it
1061 -- If not, add an AmbigErr
1062 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1064 try_default default_tys `thenTc` \ chosen_default_ty ->
1066 -- Bind the type variable and reduce the context, for real this time
1068 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1070 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1071 reduceContext (text "disambig" <+> ppr dicts)
1072 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1073 ASSERT( null frees && null ambigs )
1074 warnDefault dicts chosen_default_ty `thenTc_`
1077 | all isCreturnableClass classes
1078 = -- Default CCall stuff to (); we don't even both to check that () is an
1079 -- instance of CReturnable, because we know it is.
1080 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1081 returnTc EmptyMonoBinds
1083 | otherwise -- No defaults
1084 = complain dicts `thenNF_Tc_`
1085 returnTc EmptyMonoBinds
1088 complain = addAmbigErrs tyVarsOfInst
1089 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1090 tyvar = get_tv (head dicts) -- Should be non-empty
1091 classes = map get_clas dicts
1094 [Aside - why the defaulting mechanism is turned off when
1095 dealing with arguments and results to ccalls.
1097 When typechecking _ccall_s, TcExpr ensures that the external
1098 function is only passed arguments (and in the other direction,
1099 results) of a restricted set of 'native' types. This is
1100 implemented via the help of the pseudo-type classes,
1101 @CReturnable@ (CR) and @CCallable@ (CC.)
1103 The interaction between the defaulting mechanism for numeric
1104 values and CC & CR can be a bit puzzling to the user at times.
1113 What type has 'x' got here? That depends on the default list
1114 in operation, if it is equal to Haskell 98's default-default
1115 of (Integer, Double), 'x' has type Double, since Integer
1116 is not an instance of CR. If the default list is equal to
1117 Haskell 1.4's default-default of (Int, Double), 'x' has type
1120 To try to minimise the potential for surprises here, the
1121 defaulting mechanism is turned off in the presence of
1122 CCallable and CReturnable.
1128 ToDo: for these error messages, should we note the location as coming
1129 from the insts, or just whatever seems to be around in the monad just
1133 genCantGenErr insts -- Can't generalise these Insts
1134 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1135 nest 4 (pprInstsInFull insts)
1138 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1140 addAmbigErr ambig_tv_fn dict
1141 = tcAddSrcLoc (instLoc dict) $
1142 addErrTcM (tidy_env,
1143 sep [text "Ambiguous type variable(s)" <+>
1144 hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1145 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
1146 nest 4 (pprOrigin dict)])
1148 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1149 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1151 warnDefault dicts default_ty
1152 | not opt_WarnTypeDefaults
1156 = tcAddSrcLoc (instLoc (head dicts)) $
1159 msg | length dicts > 1
1160 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1161 $$ pprInstsInFull tidy_dicts
1163 = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1164 ptext SLIT("to type") <+> quotes (ppr default_ty)
1166 (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1169 = tcAddSrcLoc (instLoc dict) $
1170 addErrTcM (tidy_env,
1171 vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1172 nest 4 (pprOrigin dict),
1173 ptext SLIT("LHS of a rule must have no overloading")])
1175 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1177 -- Used for top-level irreducibles
1178 addTopInstanceErr dict
1179 = tcAddSrcLoc (instLoc dict) $
1180 addErrTcM (tidy_env,
1181 sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
1182 nest 4 $ pprOrigin dict])
1184 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1186 addNoInstanceErr str givens dict
1187 = tcAddSrcLoc (instLoc dict) $
1188 addErrTcM (tidy_env,
1189 sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1190 nest 4 $ parens $ pprOrigin dict],
1191 nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1193 ptext SLIT("Probable cause:") <+>
1194 vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1195 ptext SLIT("in") <+> str],
1196 if all_tyvars then empty else
1197 ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1200 all_tyvars = all isTyVarTy tys
1201 (_, tys) = getDictClassTys dict
1202 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1204 -- Used for the ...Thetas variants; all top level
1206 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1208 reduceDepthErr n stack
1209 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1210 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1211 nest 4 (pprInstsInFull stack)]
1213 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)