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, tcSimplifyRuleLhs,
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.
297 tcSimplifyRuleLhs :: LIE -> TcM s (LIE, TcDictBinds)
298 tcSimplifyRuleLhs wanted_lie
299 = reduceContext (text "tcSimplRuleLhs") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
301 returnTc (mkLIE irreds, binds)
303 wanteds = bagToList wanted_lie
305 -- Reduce methods and lits only; stop as soon as we get a dictionary
306 try_me inst | isDict inst = DontReduce
307 | otherwise = ReduceMe AddToIrreds
311 %************************************************************************
313 \subsection{Data types for the reduction mechanism}
315 %************************************************************************
317 The main control over context reduction is here
321 = ReduceMe -- Try to reduce this
322 NoInstanceAction -- What to do if there's no such instance
324 | DontReduce -- Return as irreducible
326 | Free -- Return as free
328 | FreeIfTautological -- Return as free iff it's tautological;
329 -- if not, return as irreducible
330 -- The FreeIfTautological case is to allow the possibility
331 -- of generating functions with types like
332 -- f :: C Int => Int -> Int
333 -- Here, the C Int isn't a tautology presumably because Int
334 -- isn't an instance of C in this module; but perhaps it will
335 -- be at f's call site(s). Haskell doesn't allow this at
338 data NoInstanceAction
339 = Stop -- Fail; no error message
340 -- (Only used when tautology checking.)
342 | AddToIrreds -- Just add the inst to the irreductible ones; don't
343 -- produce an error message of any kind.
344 -- It might be quite legitimate such as (Eq a)!
351 = (Avails s, -- What's available
352 [Inst], -- Insts for which try_me returned Free
353 [Inst] -- Insts for which try_me returned DontReduce
356 type Avails s = FiniteMap Inst Avail
360 TcId -- The "main Id"; that is, the Id for the Inst that
361 -- caused this avail to be put into the finite map in the first place
362 -- It is this Id that is bound to the RHS.
364 RHS -- The RHS: an expression whose value is that Inst.
365 -- The main Id should be bound to this RHS
367 [TcId] -- Extra Ids that must all be bound to the main Id.
368 -- At the end we generate a list of bindings
369 -- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
372 = NoRhs -- Used for irreducible dictionaries,
373 -- which are going to be lambda bound, or for those that are
374 -- suppplied as "given" when checking againgst a signature.
376 -- NoRhs is also used for Insts like (CCallable f)
377 -- where no witness is required.
379 | Rhs -- Used when there is a RHS
381 Bool -- True => the RHS simply selects a superclass dictionary
382 -- from a subclass dictionary.
384 -- This is useful info, because superclass selection
385 -- is cheaper than building the dictionary using its dfun,
386 -- and we can sometimes replace the latter with the former
388 | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have
389 -- an (Ord t) dictionary; then we put an (Eq t) entry in
390 -- the finite map, with an PassiveScSel. Then if the
391 -- the (Eq t) binding is ever *needed* we make it an Rhs
393 [Inst] -- List of Insts that are free in the RHS.
394 -- If the main Id is subsequently needed, we toss this list into
395 -- the needed-inst pool so that we make sure their bindings
396 -- will actually be produced.
398 -- Invariant: these Insts are already in the finite mapping
401 pprAvails avails = vcat (map pp (eltsFM avails))
403 pp (Avail main_id rhs ids)
404 = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
406 pprRhs NoRhs = text "<no rhs>"
407 pprRhs (Rhs rhs b) = ppr rhs
408 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
412 %************************************************************************
414 \subsection[reduce]{@reduce@}
416 %************************************************************************
418 The main entry point for context reduction is @reduceContext@:
421 reduceContext :: SDoc -> (Inst -> WhatToDo)
424 -> TcM s (TcDictBinds,
426 [Inst]) -- Irreducible
428 reduceContext str try_me givens wanteds
430 mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
431 mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
434 pprTrace "reduceContext" (vcat [
435 text "----------------------",
437 text "given" <+> ppr givens,
438 text "wanted" <+> ppr wanteds,
439 text "----------------------"
442 -- Build the Avail mapping from "givens"
443 foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
446 reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
448 -- Extract the bindings from avails
450 binds = foldFM add_bind EmptyMonoBinds avails
452 add_bind _ (Avail main_id rhs ids) binds
453 = foldr add_synonym (add_rhs_bind rhs binds) ids
455 add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
456 add_rhs_bind other binds = binds
458 -- Add the trivial {x = y} bindings
459 -- The main Id can end up in the list when it's first added passively
460 -- and then activated, so we have to filter it out. A bit of a hack.
462 | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
466 pprTrace ("reduceContext end") (vcat [
467 text "----------------------",
469 text "given" <+> ppr givens,
470 text "wanted" <+> ppr wanteds,
472 text "avails" <+> pprAvails avails,
473 text "irreds" <+> ppr irreds,
474 text "----------------------"
477 returnTc (binds, frees, irreds)
480 The main context-reduction function is @reduce@. Here's its game plan.
483 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
484 -- along with its depth
485 -> (Inst -> WhatToDo)
488 -> TcM s (RedState s)
492 try_me: given an inst, this function returns
494 DontReduce return this in "irreds"
495 Free return this in "frees"
497 wanteds: The list of insts to reduce
498 state: An accumulating parameter of type RedState
499 that contains the state of the algorithm
501 It returns a RedState.
503 The (n,stack) pair is just used for error reporting.
504 n is always the depth of the stack.
505 The stack is the stack of Insts being reduced: to produce X
506 I had to produce Y, to produce Y I had to produce Z, and so on.
509 reduceList (n,stack) try_me wanteds state
510 | n > opt_MaxContextReductionDepth
511 = failWithTc (reduceDepthErr n stack)
517 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
522 go [] state = returnTc state
523 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
526 -- Base case: we're done!
527 reduce stack try_me wanted state@(avails, frees, irreds)
528 -- It's the same as an existing inst, or a superclass thereof
529 | wanted `elemFM` avails
530 = returnTc (activate avails wanted, frees, irreds)
533 = case try_me wanted of {
535 ReduceMe no_instance_action -> -- It should be reduced
536 lookupInst wanted `thenNF_Tc` \ lookup_result ->
537 case lookup_result of
538 GenInst wanteds' rhs -> use_instance wanteds' rhs
539 SimpleInst rhs -> use_instance [] rhs
541 NoInstance -> -- No such instance!
542 case no_instance_action of
544 AddToIrreds -> add_to_irreds
546 Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
547 -- First, see if the inst can be reduced to a constant in one step
548 lookupInst wanted `thenNF_Tc` \ lookup_result ->
549 case lookup_result of
550 SimpleInst rhs -> use_instance [] rhs
551 other -> add_to_frees
556 FreeIfTautological -> -- It's free and this is a top level binding, so
557 -- check whether it's a tautology or not
559 add_to_irreds -- If tautology trial fails, add to irreds
561 -- If tautology succeeds, just add to frees
562 (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
563 returnTc (avails, wanted:frees, irreds))
567 DontReduce -> -- It's irreducible (or at least should not be reduced)
568 -- See if the inst can be reduced to a constant in one step
569 lookupInst wanted `thenNF_Tc` \ lookup_result ->
570 case lookup_result of
571 SimpleInst rhs -> use_instance [] rhs
572 other -> add_to_irreds
575 -- The three main actions
577 avails' = addFree avails wanted
578 -- Add the thing to the avails set so any identical Insts
579 -- will be commoned up with it right here
581 returnTc (avails', wanted:frees, irreds)
583 add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
584 returnTc (avails', frees, wanted:irreds)
586 use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
587 reduceList stack try_me wanteds' (avails', frees, irreds)
590 -- The try-me to use when trying to identify tautologies
591 -- It blunders on reducing as much as possible
592 try_me_taut inst = ReduceMe Stop -- No error recovery
597 activate :: Avails s -> Inst -> Avails s
598 -- Activate the binding for Inst, ensuring that a binding for the
599 -- wanted Inst will be generated.
600 -- (Activate its parent if necessary, recursively).
601 -- Precondition: the Inst is in Avails already
603 activate avails wanted
604 | not (instBindingRequired wanted)
608 = case lookupFM avails wanted of
610 Just (Avail main_id (PassiveScSel rhs insts) ids) ->
611 foldl activate avails' insts -- Activate anything it needs
613 avails' = addToFM avails wanted avail'
614 avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
616 Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
617 addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
619 Nothing -> panic "activate"
621 wanted_id = instToId wanted
623 addWanted avails wanted rhs_expr
624 = ASSERT( not (wanted `elemFM` avails) )
625 returnNF_Tc (addToFM avails wanted avail)
626 -- NB: we don't add the thing's superclasses too!
627 -- Why not? Because addWanted is used when we've successfully used an
628 -- instance decl to reduce something; e.g.
629 -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
630 -- Note that we pass the superclasses to the dfun, so they will be "wanted".
631 -- If we put the superclasses of "d" in avails, then we might end up
632 -- expressing "d1" in terms of "d", which would be a disaster.
634 avail = Avail (instToId wanted) rhs []
636 rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
639 addFree :: Avails s -> Inst -> (Avails s)
640 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
641 -- to avails, so that any other equal Insts will be commoned up right
642 -- here rather than also being tossed upstairs. This is really just
643 -- an optimisation, and perhaps it is more trouble that it is worth,
644 -- as the following comments show!
646 -- NB1: do *not* add superclasses. If we have
649 -- but a is not bound here, then we *don't* want to derive
650 -- dn from df here lest we lose sharing.
652 -- NB2: do *not* add the Inst to avails at all if it's a method.
653 -- The following situation shows why this is bad:
654 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
655 -- From an application (truncate f i) we get
656 -- t1 = truncate at f
658 -- If we have also have a secon occurrence of truncate, we get
659 -- t3 = truncate at f
661 -- When simplifying with i,f free, we might still notice that
662 -- t1=t3; but alas, the binding for t2 (which mentions t1)
663 -- will continue to float out!
664 -- Solution: never put methods in avail till they are captured
665 -- in which case addFree isn't used
667 | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
670 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
671 addGiven avails given
672 = -- ASSERT( not (given `elemFM` avails) )
673 -- This assertion isn't necessarily true. It's permitted
674 -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
675 -- and when typechecking instance decls we generate redundant "givens" too.
676 addAvail avails given avail
678 avail = Avail (instToId given) NoRhs []
680 addAvail avails wanted avail
681 = addSuperClasses (addToFM avails wanted avail) wanted
683 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
684 -- Add all the superclasses of the Inst to Avails
685 -- Invariant: the Inst is already in Avails.
687 addSuperClasses avails dict
691 | otherwise -- It is a dictionary
692 = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
694 (clas, tys) = getDictClassTys dict
696 (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
697 sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
699 add_sc avails ((super_clas, super_tys), sc_sel)
700 = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
702 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
705 case lookupFM avails super_dict of
707 Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
708 -- Already there, but not as a superclass selector
709 -- No need to look at its superclasses; since it's there
710 -- already they must be already in avails
711 -- However, we must remember to activate the dictionary
712 -- from which it is (now) generated
713 returnNF_Tc (activate avails' dict)
715 avails' = addToFM avails super_dict avail
716 avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection
718 Just (Avail _ _ _) -> returnNF_Tc avails
719 -- Already there; no need to do anything
722 -- Not there at all, so add it, and its superclasses
723 addAvail avails super_dict avail
725 avail = Avail (instToId super_dict)
726 (PassiveScSel sc_sel_rhs [dict])
730 %************************************************************************
732 \subsection[simple]{@Simple@ versions}
734 %************************************************************************
736 Much simpler versions when there are no bindings to make!
738 @tcSimplifyThetas@ simplifies class-type constraints formed by
739 @deriving@ declarations and when specialising instances. We are
740 only interested in the simplified bunch of class/type constraints.
742 It simplifies to constraints of the form (C a b c) where
743 a,b,c are type variables. This is required for the context of
744 instance declarations.
747 tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
748 -> ThetaType -- Wanted
749 -> TcM s ThetaType -- Needed
751 tcSimplifyThetas inst_mapper wanteds
752 = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
754 -- For multi-param Haskell, check that the returned dictionaries
755 -- don't have any of the form (C Int Bool) for which
756 -- we expect an instance here
757 -- For Haskell 98, check that all the constraints are of the form C a,
758 -- where a is a type variable
759 bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
760 isEmptyVarSet (tyVarsOfTypes tys)]
761 | otherwise = [ct | ct@(clas,tys) <- irreds,
762 not (all isTyVarTy tys)]
764 if null bad_guys then
767 mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
771 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
772 used with \tr{default} declarations. We are only interested in
773 whether it worked or not.
776 tcSimplifyCheckThetas :: ThetaType -- Given
777 -> ThetaType -- Wanted
780 tcSimplifyCheckThetas givens wanteds
781 = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
785 mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
791 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
792 -- True => irreducible
793 -- False => given, or can be derived from a given or from an irreducible
795 reduceSimple :: (Class -> InstEnv)
796 -> ThetaType -- Given
797 -> ThetaType -- Wanted
798 -> NF_TcM s ThetaType -- Irreducible
800 reduceSimple inst_mapper givens wanteds
801 = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
802 returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
804 givens_fm = foldl addNonIrred emptyFM givens
806 reduce_simple :: (Int,ThetaType) -- Stack
807 -> (Class -> InstEnv)
810 -> NF_TcM s AvailsSimple
812 reduce_simple (n,stack) inst_mapper avails wanteds
815 go avails [] = returnNF_Tc avails
816 go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
819 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
820 | wanted `elemFM` givens
824 = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
827 Nothing -> returnNF_Tc (addIrred givens wanted)
828 Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
830 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
832 = addSCs (addToFM givens ct True) ct
834 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
835 addNonIrred givens ct
836 = addSCs (addToFM givens ct False) ct
838 addSCs givens ct@(clas,tys)
839 = foldl add givens sc_theta
841 (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
842 sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
844 add givens ct = case lookupFM givens ct of
845 Nothing -> -- Add it and its superclasses
846 addSCs (addToFM givens ct False) ct
848 Just True -> -- Set its flag to False; superclasses already done
849 addToFM givens ct False
851 Just False -> -- Already done
856 %************************************************************************
858 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
860 %************************************************************************
862 When doing a binding group, we may have @Insts@ of local functions.
863 For example, we might have...
865 let f x = x + 1 -- orig local function (overloaded)
866 f.1 = f Int -- two instances of f
871 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
872 where @f@ is in scope; those @Insts@ must certainly not be passed
873 upwards towards the top-level. If the @Insts@ were binding-ified up
874 there, they would have unresolvable references to @f@.
876 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
877 For each method @Inst@ in the @init_lie@ that mentions one of the
878 @Ids@, we create a binding. We return the remaining @Insts@ (in an
879 @LIE@), as well as the @HsBinds@ generated.
882 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
884 bindInstsOfLocalFuns init_lie local_ids
885 | null overloaded_ids || null lie_for_here
887 = returnTc (init_lie, EmptyMonoBinds)
890 = reduceContext (text "bindInsts" <+> ppr local_ids)
891 try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
892 ASSERT( null irreds )
893 returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
895 overloaded_ids = filter is_overloaded local_ids
896 is_overloaded id = case splitSigmaTy (idType id) of
897 (_, theta, _) -> not (null theta)
899 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
900 -- so it's worth building a set, so that
901 -- lookup (in isMethodFor) is faster
903 -- No sense in repeatedly zonking lots of
904 -- constant constraints so filter them out here
905 (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
907 try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
912 %************************************************************************
914 \section[Disambig]{Disambiguation of overloading}
916 %************************************************************************
919 If a dictionary constrains a type variable which is
922 not mentioned in the environment
924 and not mentioned in the type of the expression
926 then it is ambiguous. No further information will arise to instantiate
927 the type variable; nor will it be generalised and turned into an extra
928 parameter to a function.
930 It is an error for this to occur, except that Haskell provided for
931 certain rules to be applied in the special case of numeric types.
936 at least one of its classes is a numeric class, and
938 all of its classes are numeric or standard
940 then the type variable can be defaulted to the first type in the
941 default-type list which is an instance of all the offending classes.
943 So here is the function which does the work. It takes the ambiguous
944 dictionaries and either resolves them (producing bindings) or
945 complains. It works by splitting the dictionary list by type
946 variable, and using @disambigOne@ to do the real business.
949 @tcSimplifyTop@ is called once per module to simplify
950 all the constant and ambiguous Insts.
953 tcSimplifyTop :: LIE -> TcM s TcDictBinds
954 tcSimplifyTop wanted_lie
955 = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
959 -- All the non-std ones are definite errors
960 (stds, non_stds) = partition isStdClassTyVarDict irreds
963 -- Group by type variable
964 std_groups = equivClasses cmp_by_tyvar stds
966 -- Pick the ones which its worth trying to disambiguate
967 (std_oks, std_bads) = partition worth_a_try std_groups
968 -- Have a try at disambiguation
969 -- if the type variable isn't bound
970 -- up with one of the non-standard classes
971 worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
972 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
974 -- Collect together all the bad guys
975 bad_guys = non_stds ++ concat std_bads
978 -- Disambiguate the ones that look feasible
979 mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
981 -- And complain about the ones that don't
982 mapNF_Tc complain bad_guys `thenNF_Tc_`
984 returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
986 wanteds = bagToList wanted_lie
987 try_me inst = ReduceMe AddToIrreds
989 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
991 complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
992 | otherwise = addAmbigErr tyVarsOfInst d
994 get_tv d = case getDictClassTys d of
995 (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
996 get_clas d = case getDictClassTys d of
1000 @disambigOne@ assumes that its arguments dictionaries constrain all
1001 the same type variable.
1003 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1004 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1005 the most common use of defaulting is code like:
1007 _ccall_ foo `seqPrimIO` bar
1009 Since we're not using the result of @foo@, the result if (presumably)
1013 disambigGroup :: [Inst] -- All standard classes of form (C a)
1014 -> TcM s TcDictBinds
1017 | any isNumericClass classes -- Guaranteed all standard classes
1018 -- see comment at the end of function for reasons as to
1019 -- why the defaulting mechanism doesn't apply to groups that
1020 -- include CCallable or CReturnable dicts.
1021 && not (any isCcallishClass classes)
1022 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1023 -- SO, TRY DEFAULT TYPES IN ORDER
1025 -- Failure here is caused by there being no type in the
1026 -- default list which can satisfy all the ambiguous classes.
1027 -- For example, if Real a is reqd, but the only type in the
1028 -- default list is Int.
1029 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
1031 try_default [] -- No defaults work, so fail
1034 try_default (default_ty : default_tys)
1035 = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
1036 -- default_tys instead
1037 tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
1040 thetas = classes `zip` repeat [default_ty]
1042 -- See if any default works, and if so bind the type variable to it
1043 -- If not, add an AmbigErr
1044 recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
1046 try_default default_tys `thenTc` \ chosen_default_ty ->
1048 -- Bind the type variable and reduce the context, for real this time
1050 chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
1052 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
1053 reduceContext (text "disambig" <+> ppr dicts)
1054 try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
1055 ASSERT( null frees && null ambigs )
1056 warnDefault dicts chosen_default_ty `thenTc_`
1059 | all isCreturnableClass classes
1060 = -- Default CCall stuff to (); we don't even both to check that () is an
1061 -- instance of CReturnable, because we know it is.
1062 unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
1063 returnTc EmptyMonoBinds
1065 | otherwise -- No defaults
1066 = complain dicts `thenNF_Tc_`
1067 returnTc EmptyMonoBinds
1070 complain = addAmbigErrs tyVarsOfInst
1071 try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
1072 tyvar = get_tv (head dicts) -- Should be non-empty
1073 classes = map get_clas dicts
1076 [Aside - why the defaulting mechanism is turned off when
1077 dealing with arguments and results to ccalls.
1079 When typechecking _ccall_s, TcExpr ensures that the external
1080 function is only passed arguments (and in the other direction,
1081 results) of a restricted set of 'native' types. This is
1082 implemented via the help of the pseudo-type classes,
1083 @CReturnable@ (CR) and @CCallable@ (CC.)
1085 The interaction between the defaulting mechanism for numeric
1086 values and CC & CR can be a bit puzzling to the user at times.
1095 What type has 'x' got here? That depends on the default list
1096 in operation, if it is equal to Haskell 98's default-default
1097 of (Integer, Double), 'x' has type Double, since Integer
1098 is not an instance of CR. If the default list is equal to
1099 Haskell 1.4's default-default of (Int, Double), 'x' has type
1102 To try to minimise the potential for surprises here, the
1103 defaulting mechanism is turned off in the presence of
1104 CCallable and CReturnable.
1110 ToDo: for these error messages, should we note the location as coming
1111 from the insts, or just whatever seems to be around in the monad just
1115 genCantGenErr insts -- Can't generalise these Insts
1116 = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1117 nest 4 (pprInstsInFull insts)
1120 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1122 addAmbigErr ambig_tv_fn dict
1123 = tcAddSrcLoc (instLoc dict) $
1124 addErrTcM (tidy_env,
1125 sep [text "Ambiguous type variable(s)" <+>
1126 hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1127 nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
1128 nest 4 (pprOrigin dict)])
1130 ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1131 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1133 warnDefault dicts default_ty
1134 | not opt_WarnTypeDefaults
1138 = tcAddSrcLoc (instLoc (head dicts)) $
1141 msg | length dicts > 1
1142 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1143 $$ pprInstsInFull tidy_dicts
1145 = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1146 ptext SLIT("to type") <+> quotes (ppr default_ty)
1148 (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1151 = tcAddSrcLoc (instLoc dict) $
1152 addErrTcM (tidy_env,
1153 vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1154 nest 4 (pprOrigin dict),
1155 ptext SLIT("LHS of a rule must have no overloading")])
1157 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1159 -- Used for top-level irreducibles
1160 addTopInstanceErr dict
1161 = tcAddSrcLoc (instLoc dict) $
1162 addErrTcM (tidy_env,
1163 sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
1164 nest 4 $ pprOrigin dict])
1166 (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1168 addNoInstanceErr str givens dict
1169 = tcAddSrcLoc (instLoc dict) $
1170 addErrTcM (tidy_env,
1171 sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1172 nest 4 $ parens $ pprOrigin dict],
1173 nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1175 ptext SLIT("Probable cause:") <+>
1176 vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1177 ptext SLIT("in") <+> str],
1178 if all_tyvars then empty else
1179 ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1182 all_tyvars = all isTyVarTy tys
1183 (_, tys) = getDictClassTys dict
1184 (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1186 -- Used for the ...Thetas variants; all top level
1188 = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1190 reduceDepthErr n stack
1191 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1192 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1193 nest 4 (pprInstsInFull stack)]
1195 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)