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(..),
134 tyVarsOfInst, tyVarsOfInsts,
135 isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
136 instToId, instBindingRequired, instCanBeGeneralised,
138 getDictClassTys, getIPs,
139 instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
140 Inst, LIE, pprInsts, pprInstsInFull,
141 mkLIE, emptyLIE, plusLIE, lieToList
143 import TcEnv ( tcGetGlobalTyVars )
144 import TcType ( TcType, TcTyVarSet, typeToTcType )
145 import TcUnify ( unifyTauTy )
147 import Class ( Class, classBigSig, classInstEnv )
148 import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
150 import Type ( Type, ThetaType, TauType, ClassContext,
152 isTyVarTy, splitSigmaTy, tyVarsOfTypes
154 import InstEnv ( InstEnv )
155 import Subst ( mkTopTyVarSubst, substClasses )
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.
184 -> TcTyVarSet -- ``Local'' type variables
185 -- ASSERT: this tyvar set is already zonked
187 -> TcM s (LIE, -- Free
188 TcDictBinds, -- Bindings
189 LIE) -- Remaining wanteds; no dups
191 tcSimplify str local_tvs wanted_lie
193 | isEmptyVarSet local_tvs
194 = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
198 = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
200 -- Check for non-generalisable insts
202 cant_generalise = filter (not . instCanBeGeneralised) irreds
204 checkTc (null cant_generalise)
205 (genCantGenErr cant_generalise) `thenTc_`
207 -- Check for ambiguous insts.
208 -- You might think these can't happen (I did) because an ambiguous
209 -- inst like (Eq a) will get tossed out with "frees", and eventually
210 -- dealt with by tcSimplifyTop.
211 -- But we can get stuck with
213 -- where "a" is one of the local_tvs, but "b" is unconstrained.
214 -- Then we must yell about the ambiguous b
215 -- But we must only do so if "b" really is unconstrained; so
216 -- we must grab the global tyvars to answer that question
217 tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
219 avail_tvs = local_tvs `unionVarSet` global_tvs
220 (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
221 ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
223 -- pprTrace "tcS" (ppr (frees, irreds')) $
224 -- pprTrace "tcS bad" (ppr bad_guys) $
225 addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
229 returnTc (mkLIE frees, binds, mkLIE irreds')
231 -- the idea behind filtering out the dependencies here is that
232 -- they've already served their purpose, and can be reconstructed
233 -- at a later point from the retained class predicates.
234 -- however, there *is* the possibility that a dependency
235 -- out-lives the predicate from which it arose.
236 -- I don't have any examples of this, but if they show up,
237 -- we'd want to consider the possibility of saving the
238 -- dependencies as hidden constraints (i.e. they'd only
239 -- show up in interface files) -- or maybe they'd be useful
240 -- as first class predicates...
241 wanteds = filter notFunDep (lieToList wanted_lie)
244 -- Does not constrain a local tyvar
245 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
246 && null (getIPs inst)
247 = -- if is_top_level then
248 -- FreeIfTautological -- Special case for inference on
249 -- -- top-level defns
253 -- We're infering (not checking) the type, and
254 -- the inst constrains a local type variable
255 | isDict inst = DontReduce -- Dicts
256 | otherwise = ReduceMe AddToIrreds -- Lits and Methods
259 @tcSimplifyAndCheck@ is similar to the above, except that it checks
260 that there is an empty wanted-set at the end. It may still return
261 some of constant insts, which have to be resolved finally at the end.
266 -> TcTyVarSet -- ``Local'' type variables
267 -- ASSERT: this tyvar set is already zonked
268 -> LIE -- Given; constrain only local tyvars
270 -> TcM s (LIE, -- Free
271 TcDictBinds) -- Bindings
273 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
274 | isEmptyVarSet local_tvs
275 -- This can happen quite legitimately; for example in
276 -- instance Num Int where ...
277 = returnTc (wanted_lie, EmptyMonoBinds)
280 = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
282 -- Complain about any irreducible ones
283 mapNF_Tc complain irreds `thenNF_Tc_`
286 returnTc (mkLIE frees, binds)
288 givens = lieToList given_lie
289 -- see comment on wanteds in tcSimplify
290 wanteds = filter notFunDep (lieToList wanted_lie)
291 given_dicts = filter isDict givens
294 -- Does not constrain a local tyvar
295 | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
298 -- When checking against a given signature we always reduce
299 -- until we find a match against something given, or can't reduce
301 = ReduceMe AddToIrreds
303 complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
304 addNoInstanceErr str given_dicts dict
307 On the LHS of transformation rules we only simplify methods and constants,
308 getting dictionaries. We want to keep all of them unsimplified, to serve
309 as the available stuff for the RHS of the rule.
311 The same thing is used for specialise pragmas. Consider
314 {-# SPECIALISE f :: Int -> Int #-}
317 The type checker generates a binding like:
319 f_spec = (f :: Int -> Int)
321 and we want to end up with
323 f_spec = _inline_me_ (f Int dNumInt)
325 But that means that we must simplify the Method for f to (f Int dNumInt)!
326 So tcSimplifyToDicts squeezes out all Methods.
329 tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
330 tcSimplifyToDicts wanted_lie
331 = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
333 returnTc (mkLIE irreds, binds)
335 -- see comment on wanteds in tcSimplify
336 wanteds = filter notFunDep (lieToList wanted_lie)
338 -- Reduce methods and lits only; stop as soon as we get a dictionary
339 try_me inst | isDict inst = DontReduce
340 | otherwise = ReduceMe AddToIrreds
345 %************************************************************************
347 \subsection{Data types for the reduction mechanism}
349 %************************************************************************
351 The main control over context reduction is here
355 = ReduceMe -- Try to reduce this
356 NoInstanceAction -- What to do if there's no such instance
358 | DontReduce -- Return as irreducible
360 | Free -- Return as free
362 | FreeIfTautological -- Return as free iff it's tautological;
363 -- if not, return as irreducible
364 -- The FreeIfTautological case is to allow the possibility
365 -- of generating functions with types like
366 -- f :: C Int => Int -> Int
367 -- Here, the C Int isn't a tautology presumably because Int
368 -- isn't an instance of C in this module; but perhaps it will
369 -- be at f's call site(s). Haskell doesn't allow this at
372 data NoInstanceAction
373 = Stop -- Fail; no error message
374 -- (Only used when tautology checking.)
376 | AddToIrreds -- Just add the inst to the irreductible ones; don't
377 -- produce an error message of any kind.
378 -- It might be quite legitimate such as (Eq a)!
385 = (Avails s, -- What's available
386 [Inst], -- Insts for which try_me returned Free
387 [Inst] -- Insts for which try_me returned DontReduce
390 type Avails s = FiniteMap Inst Avail
394 TcId -- The "main Id"; that is, the Id for the Inst that
395 -- caused this avail to be put into the finite map in the first place
396 -- It is this Id that is bound to the RHS.
398 RHS -- The RHS: an expression whose value is that Inst.
399 -- The main Id should be bound to this RHS
401 [TcId] -- Extra Ids that must all be bound to the main Id.
402 -- At the end we generate a list of bindings
403 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
406 = NoRhs -- Used for irreducible dictionaries,
407 -- which are going to be lambda bound, or for those that are
408 -- suppplied as "given" when checking againgst a signature.
410 -- NoRhs is also used for Insts like (CCallable f)
411 -- where no witness is required.
413 | Rhs -- Used when there is a RHS
415 Bool -- True => the RHS simply selects a superclass dictionary
416 -- from a subclass dictionary.
418 -- This is useful info, because superclass selection
419 -- is cheaper than building the dictionary using its dfun,
420 -- and we can sometimes replace the latter with the former
422 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
423 -- an (Ord t) dictionary; then we put an (Eq t) entry in
424 -- the finite map, with an PassiveScSel. Then if the
425 -- the (Eq t) binding is ever *needed* we make it an Rhs
427 [Inst] -- List of Insts that are free in the RHS.
428 -- If the main Id is subsequently needed, we toss this list into
429 -- the needed-inst pool so that we make sure their bindings
430 -- will actually be produced.
432 -- Invariant: these Insts are already in the finite mapping
435 pprAvails avails = vcat (map pprAvail (eltsFM avails))
437 pprAvail (Avail main_id rhs ids)
438 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
440 pprRhs NoRhs = text "<no rhs>"
441 pprRhs (Rhs rhs b) = ppr rhs
442 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
446 %************************************************************************
448 \subsection[reduce]{@reduce@}
450 %************************************************************************
452 The main entry point for context reduction is @reduceContext@:
455 reduceContext :: SDoc -> (Inst -> WhatToDo)
458 -> TcM s (TcDictBinds,
460 [Inst]) -- Irreducible
462 reduceContext str try_me givens wanteds
464 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
465 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
468 pprTrace "reduceContext" (vcat [
469 text "----------------------",
471 text "given" <+> ppr givens,
472 text "wanted" <+> ppr wanteds,
473 text "----------------------"
476 -- Build the Avail mapping from "givens"
477 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
480 reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
482 -- Extract the bindings from avails
484 binds = foldFM add_bind EmptyMonoBinds avails
486 add_bind _ (Avail main_id rhs ids) binds
487 = foldr add_synonym (add_rhs_bind rhs binds) ids
489 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
490 add_rhs_bind other binds = binds
492 -- Add the trivial {x = y} bindings
493 -- The main Id can end up in the list when it's first added passively
494 -- and then activated, so we have to filter it out. A bit of a hack.
496 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
500 pprTrace ("reduceContext end") (vcat [
501 text "----------------------",
503 text "given" <+> ppr givens,
504 text "wanted" <+> ppr wanteds,
506 text "avails" <+> pprAvails avails,
507 text "irreds" <+> ppr irreds,
508 text "----------------------"
511 returnTc (binds, frees, irreds)
514 The main context-reduction function is @reduce@. Here's its game plan.
517 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
518 -- along with its depth
519 -> (Inst -> WhatToDo)
522 -> TcM s (RedState s)
526 try_me: given an inst, this function returns
528 DontReduce return this in "irreds"
529 Free return this in "frees"
531 wanteds: The list of insts to reduce
532 state: An accumulating parameter of type RedState
533 that contains the state of the algorithm
535 It returns a RedState.
537 The (n,stack) pair is just used for error reporting.
538 n is always the depth of the stack.
539 The stack is the stack of Insts being reduced: to produce X
540 I had to produce Y, to produce Y I had to produce Z, and so on.
543 reduceList (n,stack) try_me wanteds state
544 | n > opt_MaxContextReductionDepth
545 = failWithTc (reduceDepthErr n stack)
551 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
556 go [] state = returnTc state
557 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
560 -- Base case: we're done!
561 reduce stack try_me wanted state@(avails, frees, irreds)
562 -- It's the same as an existing inst, or a superclass thereof
563 | wanted `elemFM` avails
564 = returnTc (activate avails wanted, frees, irreds)
567 = case try_me wanted of {
569 ReduceMe no_instance_action -> -- It should be reduced
570 lookupInst wanted `thenNF_Tc` \ lookup_result ->
571 case lookup_result of
572 GenInst wanteds' rhs -> use_instance wanteds' rhs
573 SimpleInst rhs -> use_instance [] rhs
575 NoInstance -> -- No such instance!
576 case no_instance_action of
578 AddToIrreds -> add_to_irreds
580 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
581 -- First, see if the inst can be reduced to a constant in one step
582 lookupInst wanted `thenNF_Tc` \ lookup_result ->
583 case lookup_result of
584 SimpleInst rhs -> use_instance [] rhs
585 other -> add_to_frees
590 FreeIfTautological -> -- It's free and this is a top level binding, so
591 -- check whether it's a tautology or not
593 add_to_irreds -- If tautology trial fails, add to irreds
595 -- If tautology succeeds, just add to frees
596 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
597 returnTc (avails, wanted:frees, irreds))
601 DontReduce -> -- It's irreducible (or at least should not be reduced)
602 -- See if the inst can be reduced to a constant in one step
603 lookupInst wanted `thenNF_Tc` \ lookup_result ->
604 case lookup_result of
605 SimpleInst rhs -> use_instance [] rhs
606 other -> add_to_irreds
609 -- The three main actions
611 avails' = addFree avails wanted
612 -- Add the thing to the avails set so any identical Insts
613 -- will be commoned up with it right here
615 returnTc (avails', wanted:frees, irreds)
617 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
618 returnTc (avails', frees, wanted:irreds)
620 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
621 reduceList stack try_me wanteds' (avails', frees, irreds)
624 -- The try-me to use when trying to identify tautologies
625 -- It blunders on reducing as much as possible
626 try_me_taut inst = ReduceMe Stop -- No error recovery
631 activate :: Avails s -> Inst -> Avails s
632 -- Activate the binding for Inst, ensuring that a binding for the
633 -- wanted Inst will be generated.
634 -- (Activate its parent if necessary, recursively).
635 -- Precondition: the Inst is in Avails already
637 activate avails wanted
638 | not (instBindingRequired wanted)
642 = case lookupFM avails wanted of
644 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
645 foldl activate avails' insts -- Activate anything it needs
647 avails' = addToFM avails wanted avail'
648 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
650 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
651 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
653 Nothing -> panic "activate"
655 wanted_id = instToId wanted
657 addWanted avails wanted rhs_expr
658 = ASSERT( not (wanted `elemFM` avails) )
659 returnNF_Tc (addToFM avails wanted avail)
660 -- NB: we don't add the thing's superclasses too!
661 -- Why not? Because addWanted is used when we've successfully used an
662 -- instance decl to reduce something; e.g.
663 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
664 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
665 -- If we put the superclasses of "d" in avails, then we might end up
666 -- expressing "d1" in terms of "d", which would be a disaster.
668 avail = Avail (instToId wanted) rhs []
670 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
673 addFree :: Avails s -> Inst -> (Avails s)
674 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
675 -- to avails, so that any other equal Insts will be commoned up right
676 -- here rather than also being tossed upstairs. This is really just
677 -- an optimisation, and perhaps it is more trouble that it is worth,
678 -- as the following comments show!
680 -- NB1: do *not* add superclasses. If we have
683 -- but a is not bound here, then we *don't* want to derive
684 -- dn from df here lest we lose sharing.
686 -- NB2: do *not* add the Inst to avails at all if it's a method.
687 -- The following situation shows why this is bad:
688 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
689 -- From an application (truncate f i) we get
690 -- t1 = truncate at f
692 -- If we have also have a secon occurrence of truncate, we get
693 -- t3 = truncate at f
695 -- When simplifying with i,f free, we might still notice that
696 -- t1=t3; but alas, the binding for t2 (which mentions t1)
697 -- will continue to float out!
698 -- Solution: never put methods in avail till they are captured
699 -- in which case addFree isn't used
701 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
704 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
705 addGiven avails given
706 = -- ASSERT( not (given `elemFM` avails) )
707 -- This assertion isn't necessarily true. It's permitted
708 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
709 -- and when typechecking instance decls we generate redundant "givens" too.
710 -- addAvail avails given avail
711 addAvail avails given avail `thenNF_Tc` \av ->
712 zonkInst given `thenNF_Tc` \given' ->
715 avail = Avail (instToId given) NoRhs []
717 addAvail avails wanted avail
718 = addSuperClasses (addToFM avails wanted avail) wanted
720 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
721 -- Add all the superclasses of the Inst to Avails
722 -- Invariant: the Inst is already in Avails.
724 addSuperClasses avails dict
728 | otherwise -- It is a dictionary
729 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
731 (clas, tys) = getDictClassTys dict
733 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
734 sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
736 add_sc avails ((super_clas, super_tys), sc_sel)
737 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
739 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
742 case lookupFM avails super_dict of
744 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
745 -- Already there, but not as a superclass selector
746 -- No need to look at its superclasses; since it's there
747 -- already they must be already in avails
748 -- However, we must remember to activate the dictionary
749 -- from which it is (now) generated
750 returnNF_Tc (activate avails' dict)
752 avails' = addToFM avails super_dict avail
753 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
755 Just (Avail _ _ _) -> returnNF_Tc avails
756 -- Already there; no need to do anything
759 -- Not there at all, so add it, and its superclasses
760 addAvail avails super_dict avail
762 avail = Avail (instToId super_dict)
763 (PassiveScSel sc_sel_rhs [dict])
767 %************************************************************************
769 \subsection[simple]{@Simple@ versions}
771 %************************************************************************
773 Much simpler versions when there are no bindings to make!
775 @tcSimplifyThetas@ simplifies class-type constraints formed by
776 @deriving@ declarations and when specialising instances. We are
777 only interested in the simplified bunch of class/type constraints.
779 It simplifies to constraints of the form (C a b c) where
780 a,b,c are type variables. This is required for the context of
781 instance declarations.
784 tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
785 -> ClassContext -- Wanted
786 -> TcM s ClassContext -- Needed
788 tcSimplifyThetas inst_mapper wanteds
789 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
791 -- For multi-param Haskell, check that the returned dictionaries
792 -- don't have any of the form (C Int Bool) for which
793 -- we expect an instance here
794 -- For Haskell 98, check that all the constraints are of the form C a,
795 -- where a is a type variable
796 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
797 isEmptyVarSet (tyVarsOfTypes tys)]
798 | otherwise = [ct | ct@(clas,tys) <- irreds,
799 not (all isTyVarTy tys)]
801 if null bad_guys then
804 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
808 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
809 used with \tr{default} declarations. We are only interested in
810 whether it worked or not.
813 tcSimplifyCheckThetas :: ClassContext -- Given
814 -> ClassContext -- Wanted
817 tcSimplifyCheckThetas givens wanteds
818 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
822 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
828 type AvailsSimple = FiniteMap (Class,[Type]) Bool
829 -- True => irreducible
830 -- False => given, or can be derived from a given or from an irreducible
832 reduceSimple :: (Class -> InstEnv)
833 -> ClassContext -- Given
834 -> ClassContext -- Wanted
835 -> NF_TcM s ClassContext -- Irreducible
837 reduceSimple inst_mapper givens wanteds
838 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
839 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
841 givens_fm = foldl addNonIrred emptyFM givens
843 reduce_simple :: (Int,ClassContext) -- Stack
844 -> (Class -> InstEnv)
847 -> NF_TcM s AvailsSimple
849 reduce_simple (n,stack) inst_mapper avails wanteds
852 go avails [] = returnNF_Tc avails
853 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
856 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
857 | wanted `elemFM` givens
861 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
864 Nothing -> returnNF_Tc (addIrred givens wanted)
865 Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
867 addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
868 addIrred givens ct@(clas,tys)
869 = addSCs (addToFM givens ct True) ct
871 addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
872 addNonIrred givens ct@(clas,tys)
873 = addSCs (addToFM givens ct False) ct
875 addSCs givens ct@(clas,tys)
876 = foldl add givens sc_theta
878 (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
879 sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
881 add givens ct@(clas, tys)
882 = case lookupFM givens ct of
883 Nothing -> -- Add it and its superclasses
884 addSCs (addToFM givens ct False) ct
886 Just True -> -- Set its flag to False; superclasses already done
887 addToFM givens ct False
889 Just False -> -- Already done
894 %************************************************************************
896 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
898 %************************************************************************
900 When doing a binding group, we may have @Insts@ of local functions.
901 For example, we might have...
903 let f x = x + 1 -- orig local function (overloaded)
904 f.1 = f Int -- two instances of f
909 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
910 where @f@ is in scope; those @Insts@ must certainly not be passed
911 upwards towards the top-level. If the @Insts@ were binding-ified up
912 there, they would have unresolvable references to @f@.
914 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
915 For each method @Inst@ in the @init_lie@ that mentions one of the
916 @Ids@, we create a binding. We return the remaining @Insts@ (in an
917 @LIE@), as well as the @HsBinds@ generated.
920 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
922 bindInstsOfLocalFuns init_lie local_ids
923 | null overloaded_ids || null lie_for_here
925 = returnTc (init_lie, EmptyMonoBinds)
928 = reduceContext (text "bindInsts" <+> ppr local_ids)
929 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
930 ASSERT( null irreds )
931 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
933 overloaded_ids = filter is_overloaded local_ids
934 is_overloaded id = case splitSigmaTy (idType id) of
935 (_, theta, _) -> not (null theta)
937 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
938 -- so it's worth building a set, so that
939 -- lookup (in isMethodFor) is faster
941 -- No sense in repeatedly zonking lots of
942 -- constant constraints so filter them out here
943 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
945 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
950 %************************************************************************
952 \section[Disambig]{Disambiguation of overloading}
954 %************************************************************************
957 If a dictionary constrains a type variable which is
960 not mentioned in the environment
962 and not mentioned in the type of the expression
964 then it is ambiguous. No further information will arise to instantiate
965 the type variable; nor will it be generalised and turned into an extra
966 parameter to a function.
968 It is an error for this to occur, except that Haskell provided for
969 certain rules to be applied in the special case of numeric types.
974 at least one of its classes is a numeric class, and
976 all of its classes are numeric or standard
978 then the type variable can be defaulted to the first type in the
979 default-type list which is an instance of all the offending classes.
981 So here is the function which does the work. It takes the ambiguous
982 dictionaries and either resolves them (producing bindings) or
983 complains. It works by splitting the dictionary list by type
984 variable, and using @disambigOne@ to do the real business.
987 @tcSimplifyTop@ is called once per module to simplify
988 all the constant and ambiguous Insts.
991 tcSimplifyTop :: LIE -> TcM s TcDictBinds
992 tcSimplifyTop wanted_lie
993 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
997 -- All the non-std ones are definite errors
998 (stds, non_stds) = partition isStdClassTyVarDict irreds
1001 -- Group by type variable
1002 std_groups = equivClasses cmp_by_tyvar stds
1004 -- Pick the ones which its worth trying to disambiguate
1005 (std_oks, std_bads) = partition worth_a_try std_groups
1006 -- Have a try at disambiguation
1007 -- if the type variable isn't bound
1008 -- up with one of the non-standard classes
1009 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
1010 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
1012 -- Collect together all the bad guys
1013 bad_guys = non_stds ++ concat std_bads
1016 -- Disambiguate the ones that look feasible
1017 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
1019 -- And complain about the ones that don't
1020 mapNF_Tc complain bad_guys `thenNF_Tc_`
1022 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1024 -- see comment on wanteds in tcSimplify
1025 wanteds = filter notFunDep (lieToList wanted_lie)
1026 try_me inst = ReduceMe AddToIrreds
1028 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1030 complain d | not (null (getIPs d)) = addTopIPErr d
1031 | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1032 | otherwise = addAmbigErr tyVarsOfInst d
1034 get_tv d = case getDictClassTys d of
1035 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1036 get_clas d = case getDictClassTys d of
1037 (clas, [ty]) -> clas
1040 @disambigOne@ assumes that its arguments dictionaries constrain all
1041 the same type variable.
1043 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1044 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1045 the most common use of defaulting is code like:
1047 _ccall_ foo `seqPrimIO` bar
1049 Since we're not using the result of @foo@, the result if (presumably)
1053 disambigGroup :: [Inst] -- All standard classes of form (C a)
1054 -> TcM s TcDictBinds
1057 | any isNumericClass classes -- Guaranteed all standard classes
1058 -- see comment at the end of function for reasons as to
1059 -- why the defaulting mechanism doesn't apply to groups that
1060 -- include CCallable or CReturnable dicts.
1061 && not (any isCcallishClass classes)
1062 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1063 -- SO, TRY DEFAULT TYPES IN ORDER
1065 -- Failure here is caused by there being no type in the
1066 -- default list which can satisfy all the ambiguous classes.
1067 -- For example, if Real a is reqd, but the only type in the
1068 -- default list is Int.
1069 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1071 try_default [] -- No defaults work, so fail
1074 try_default (default_ty : default_tys)
1075 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1076 -- default_tys instead
1077 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1080 thetas = classes `zip` repeat [default_ty]
1082 -- See if any default works, and if so bind the type variable to it
1083 -- If not, add an AmbigErr
1084 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1086 try_default default_tys `thenTc` \ chosen_default_ty ->
1088 -- Bind the type variable and reduce the context, for real this time
1090 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1092 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1093 reduceContext (text "disambig" <+> ppr dicts)
1094 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1095 ASSERT( null frees && null ambigs )
1096 warnDefault dicts chosen_default_ty `thenTc_`
1099 | all isCreturnableClass classes
1100 = -- Default CCall stuff to (); we don't even both to check that () is an
1101 -- instance of CReturnable, because we know it is.
1102 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1103 returnTc EmptyMonoBinds
1105 | otherwise -- No defaults
1106 = complain dicts `thenNF_Tc_`
1107 returnTc EmptyMonoBinds
1110 complain = addAmbigErrs tyVarsOfInst
1111 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1112 tyvar = get_tv (head dicts) -- Should be non-empty
1113 classes = map get_clas dicts
1116 [Aside - why the defaulting mechanism is turned off when
1117 dealing with arguments and results to ccalls.
1119 When typechecking _ccall_s, TcExpr ensures that the external
1120 function is only passed arguments (and in the other direction,
1121 results) of a restricted set of 'native' types. This is
1122 implemented via the help of the pseudo-type classes,
1123 @CReturnable@ (CR) and @CCallable@ (CC.)
1125 The interaction between the defaulting mechanism for numeric
1126 values and CC & CR can be a bit puzzling to the user at times.
1135 What type has 'x' got here? That depends on the default list
1136 in operation, if it is equal to Haskell 98's default-default
1137 of (Integer, Double), 'x' has type Double, since Integer
1138 is not an instance of CR. If the default list is equal to
1139 Haskell 1.4's default-default of (Int, Double), 'x' has type
1142 To try to minimise the potential for surprises here, the
1143 defaulting mechanism is turned off in the presence of
1144 CCallable and CReturnable.
1150 ToDo: for these error messages, should we note the location as coming
1151 from the insts, or just whatever seems to be around in the monad just
1155 genCantGenErr insts -- Can't generalise these Insts
1156 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1157 nest 4 (pprInstsInFull insts)
1160 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1162 addAmbigErr ambig_tv_fn dict
1163 = addInstErrTcM (instLoc dict)
1165 sep [text "Ambiguous type variable(s)" <+>
1166 hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1167 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1169 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1170 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1172 warnDefault dicts default_ty
1173 | not opt_WarnTypeDefaults
1179 msg | length dicts > 1
1180 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1181 $$ pprInstsInFull tidy_dicts
1183 = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1184 ptext SLIT("to type") <+> quotes (ppr default_ty)
1186 (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1189 = addInstErrTcM (instLoc dict)
1191 vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1192 nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
1194 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1197 = addInstErrTcM (instLoc dict)
1199 ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
1201 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1203 -- Used for top-level irreducibles
1204 addTopInstanceErr dict
1205 = addInstErrTcM (instLoc dict)
1207 ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1209 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1211 addNoInstanceErr str givens dict
1212 = addInstErrTcM (instLoc dict)
1214 sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1215 nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1217 ptext SLIT("Probable cause:") <+>
1218 vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1219 ptext SLIT("in") <+> str],
1220 if isDict dict && all_tyvars then empty else
1221 ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1224 all_tyvars = all isTyVarTy tys
1225 (_, tys) = getDictClassTys dict
1226 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1228 -- Used for the ...Thetas variants; all top level
1230 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1232 reduceDepthErr n stack
1233 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1234 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1235 nest 4 (pprInstsInFull stack)]
1237 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)