2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcSimplify]{TcSimplify}
7 #include "HsVersions.h"
10 tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals,
11 tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
17 import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
18 Match, HsBinds, Qual, PolyType, ArithSeqInfo,
19 GRHSsAndBinds, Stmt, Fake )
20 import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
23 import Inst ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst,
24 instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
25 Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
26 InstOrigin(..), OverloadedLit )
27 import TcEnv ( tcGetGlobalTyVars )
28 import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
29 import Unify ( unifyTauTy )
31 import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
32 snocBag, consBag, unionBags, isEmptyBag )
33 import Class ( isNumericClass, isStandardClass, isCcallishClass,
34 isSuperClassOf, getSuperDictSelId )
36 import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
37 import Outputable ( Outputable(..){-instance * []-} )
38 import PprType ( GenType, GenTyVar )
40 import SrcLoc ( mkUnknownSrcLoc )
42 import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy )
43 import TysWiredIn ( intTy )
44 import TyVar ( GenTyVar, GenTyVarSet(..),
45 elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
46 isEmptyTyVarSet, tyVarSetToList )
47 import Unique ( Unique )
51 %************************************************************************
53 \subsection[tcSimplify-main]{Main entry function}
55 %************************************************************************
57 * May modify the substitution to bind ambiguous type variables.
61 (1) If an inst constrains only ``global'' type variables, (or none),
62 return it as a ``global'' inst.
66 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
67 constraining only a type variable.
69 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
70 Otherwise it must be ambiguous, so try to resolve the ambiguity.
74 tcSimpl :: Bool -- True <=> simplify const insts
75 -> TcTyVarSet s -- ``Global'' type variables
76 -> TcTyVarSet s -- ``Local'' type variables
77 -- ASSERT: both these tyvar sets are already zonked
78 -> LIE s -- Given; these constrain only local tyvars
80 -> TcM s (LIE s, -- Free
81 [(TcIdOcc s,TcExpr s)], -- Bindings
82 LIE s) -- Remaining wanteds; no dups
84 tcSimpl squash_consts global_tvs local_tvs givens wanteds
85 = -- ASSSERT: global_tvs and local_tvs are already zonked
86 -- Make sure the insts fixed points of the substitution
87 zonkLIE givens `thenNF_Tc` \ givens ->
88 zonkLIE wanteds `thenNF_Tc` \ wanteds ->
90 -- Deal with duplicates and type constructors
92 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
93 givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
95 -- Now disambiguate if necessary
97 ambigs = filterBag is_ambiguous locals_and_ambigs
99 if not (isEmptyBag ambigs) then
100 -- Some ambiguous dictionaries. We now disambiguate them,
101 -- which binds the offending type variables to suitable types in the
102 -- substitution, and then we retry the whole process. This
103 -- time there won't be any ambiguous ones.
104 -- There's no need to back-substitute on global and local tvs,
105 -- because the ambiguous type variables can't be in either.
107 -- Why do we retry the whole process? Because binding a type variable
108 -- to a particular type might enable a short-cut simplification which
109 -- elimTyCons will have missed the first time.
111 disambiguateDicts ambigs `thenTc_`
112 tcSimpl squash_consts global_tvs local_tvs givens wanteds
115 -- No ambiguous dictionaries. Just bash on with the results
118 -- Check for non-generalisable insts
120 locals = locals_and_ambigs -- ambigs is empty
121 cant_generalise = filterBag (not . instCanBeGeneralised) locals
123 checkTc (isEmptyBag cant_generalise)
124 (genCantGenErr cant_generalise) `thenTc_`
127 -- Deal with superclass relationships
128 elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) ->
131 returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
133 is_ambiguous (Dict _ _ ty _ _)
134 = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
137 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
138 the ``don't-squash-consts'' flag set depending on top-level ness. For
139 top level defns we *do* squash constants, so that they stay local to a
140 single defn. This makes things which are inlined more likely to be
141 exportable, because their constants are "inside". Later passes will
142 float them out if poss, after inlinings are sorted out.
146 :: TcTyVarSet s -- ``Local'' type variables
148 -> TcM s (LIE s, -- Free
149 [(TcIdOcc s,TcExpr s)], -- Bindings
150 LIE s) -- Remaining wanteds; no dups
152 tcSimplify local_tvs wanteds
153 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
154 tcSimpl False global_tvs local_tvs emptyBag wanteds
157 @tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get
158 to specify some extra global type variables that the simplifer will treat
159 as free in the environment.
162 tcSimplifyWithExtraGlobals
163 :: TcTyVarSet s -- Extra ``Global'' type variables
164 -> TcTyVarSet s -- ``Local'' type variables
166 -> TcM s (LIE s, -- Free
167 [(TcIdOcc s,TcExpr s)], -- Bindings
168 LIE s) -- Remaining wanteds; no dups
170 tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds
171 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
173 (global_tvs `unionTyVarSets` extra_global_tvs)
174 local_tvs emptyBag wanteds
177 @tcSimplifyAndCheck@ is similar to the above, except that it checks
178 that there is an empty wanted-set at the end. It may still return
179 some of constant insts, which have to be resolved finally at the end.
183 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
186 -> TcM s (LIE s, -- Free
187 [(TcIdOcc s,TcExpr s)]) -- Bindings
189 tcSimplifyAndCheck local_tvs givens wanteds
190 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
191 tcSimpl False global_tvs local_tvs
192 givens wanteds `thenTc` \ (free_insts, binds, wanteds') ->
193 checkTc (isEmptyBag wanteds')
194 (reduceErr wanteds') `thenTc_`
195 returnTc (free_insts, binds)
198 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
202 tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
204 -> TcM s (LIE s, -- Free
205 [(TcIdOcc s,TcExpr s)]) -- Bindings
208 tcSimplifyRank2 local_tvs givens
209 = zonkLIE givens `thenNF_Tc` \ givens' ->
211 (\tv -> not (tv `elementOfTyVarSet` local_tvs))
212 -- This predicate claims that all
213 -- any non-local tyvars are global,
214 -- thereby postponing dealing with
215 -- ambiguity until the enclosing Gen
216 emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
218 checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_`
220 returnTc (free, bagToList dict_binds)
223 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
224 mechansim with the extra flag to say ``beat out constant insts''.
227 tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
229 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
230 tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) ->
234 @tcSimplifyThetas@ simplifies class-type constraints formed by
235 @deriving@ declarations and when specialising instances. We are
236 only interested in the simplified bunch of class/type constraints.
239 tcSimplifyThetas :: (Class -> TauType -> InstOrigin s) -- Creates an origin for the dummy dicts
240 -> [(Class, TauType)] -- Simplify this
241 -> TcM s [(Class, TauType)] -- Result
243 tcSimplifyThetas = panic "tcSimplifyThetas"
246 tcSimplifyThetas mk_inst_origin theta
248 dicts = listToBag (map mk_dummy_dict theta)
250 -- Do the business (this is just the heart of "tcSimpl")
251 elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ (_, _, dicts2) ->
253 -- Deal with superclass relationships
254 elimSCs [] dicts2 `thenNF_Tc` \ (_, dicts3) ->
256 returnTc (map unmk_dummy_dict (bagToList dicts3))
258 mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc
259 uniq = panic "tcSimplifyThetas:uniq"
261 unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty)
265 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
266 used with \tr{default} declarations. We are only interested in
267 whether it worked or not.
270 tcSimplifyCheckThetas :: InstOrigin s -- context; for error msg
271 -> [(Class, TauType)] -- Simplify this
274 tcSimplifyCheckThetas = panic "tcSimplifyCheckThetas"
277 tcSimplifyCheckThetas origin theta
279 dicts = map mk_dummy_dict theta
281 -- Do the business (this is just the heart of "tcSimpl")
282 elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ _ ->
286 mk_dummy_dict (clas, ty)
287 = Dict uniq clas ty origin mkUnknownSrcLoc
289 uniq = panic "tcSimplifyCheckThetas:uniq"
294 %************************************************************************
296 \subsection[elimTyCons]{@elimTyCons@}
298 %************************************************************************
301 elimTyCons :: Bool -- True <=> Simplify const insts
302 -> (TcTyVar s -> Bool) -- Free tyvar predicate
305 -> TcM s (LIE s, -- Free
306 Bag (TcIdOcc s, TcExpr s), -- Bindings
307 LIE s -- Remaining wanteds; no dups;
308 -- dicts only (no Methods)
312 The bindings returned may mention any or all of ``givens'', so the
313 order in which the generated binds are put together is {\em tricky}.
314 Case~4 of @try@ is the general case to see.
316 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
318 (1) first look up @wanted@; this gives us one binding to heave in:
321 (2) step (1) also gave us some @simpler_wanteds@; we simplify
322 these and get some (simpler-wanted-)bindings {\em that must be
323 in scope} for the @wanted=rhs@ binding above!
325 (3) we simplify the remaining @wanteds@ (recursive call), giving
326 us yet more bindings.
328 The final arrangement of the {\em non-recursive} bindings is
330 let <simpler-wanted-binds> in
332 let <yet-more-bindings> ...
335 elimTyCons squash_consts is_free_tv givens wanteds
336 = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) ->
337 returnTc (free,binds,irreds)
339 -- eTC :: LIE s -> [Inst s]
340 -- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
342 eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
344 eTC givens (wanted:wanteds)
345 -- Case 0: same as an existing inst
346 | maybeToBool maybe_equiv
347 = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
349 -- Create a new binding iff it's needed
350 this = expectJust "eTC" maybe_equiv
351 new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
355 returnTc (givens1, frees, new_binds, irreds)
357 -- Case 1: constrains no type variables at all
358 -- In this case we have a quick go to see if it has an
359 -- instance which requires no inputs (ie a constant); if so we use
360 -- it; if not, we give up on the instance and just heave it out the
361 -- top in the free result
362 | isEmptyTyVarSet tvs_of_wanted
363 = simplify_it squash_consts {- If squash_consts is false,
364 simplify only if trival -}
365 givens wanted wanteds
367 -- Case 2: constrains free vars only, so fling it out the top in free_ids
368 | all is_free_tv (tyVarSetToList tvs_of_wanted)
369 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
370 returnTc (givens1, wanted `consBag` frees, binds, irreds)
372 -- Case 3: is a dict constraining only a tyvar,
373 -- so return it as part of the "wanteds" result
375 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
376 returnTc (givens1, frees, binds, wanted `consBag` irreds)
378 -- Case 4: is not a simple dict, so look up in instance environment
380 = simplify_it True {- Simplify even if not trivial -}
381 givens wanted wanteds
383 tvs_of_wanted = tyVarsOfInst wanted
385 -- Look for something in "givens" that matches "wanted"
386 Just the_equiv = maybe_equiv
387 maybe_equiv = foldBag seqMaybe try Nothing givens
388 try given | wanted `matchesInst` given = Just given
389 | otherwise = Nothing
392 simplify_it simplify_always givens wanted wanteds
393 -- Recover immediately on no-such-instance errors
394 = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE))
395 (simplify_one simplify_always givens wanted)
396 `thenTc` \ (givens1, frees1, binds1, irreds1) ->
397 eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
398 returnTc (givens2, frees1 `plusLIE` frees2,
399 binds1 `unionBags` binds2,
400 irreds1 `plusLIE` irreds2)
403 simplify_one simplify_always givens wanted
404 | not (instBindingRequired wanted)
405 = -- No binding required for this chap, so squash right away
406 lookupInst wanted `thenTc` \ (simpler_wanteds, _) ->
407 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
408 returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
411 = -- An binding is required for this inst
412 lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
414 if (not_var rhs && not simplify_always) then
415 -- Ho ho! It isn't trivial to simplify "wanted",
416 -- because the rhs isn't a simple variable. Unless the flag
417 -- simplify_always is set, just give up now and
418 -- just fling it out the top.
419 returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
421 -- Aha! Either it's easy, or simplify_always is True
422 -- so we must do it right here.
423 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
424 returnTc (wanted `consLIE` givens1, frees1,
425 binds1 `snocBag` bind,
428 not_var :: TcExpr s -> Bool
429 not_var (HsVar _) = False
434 %************************************************************************
436 \subsection[elimSCs]{@elimSCs@}
438 %************************************************************************
441 elimSCs :: LIE s -- Given; no dups
442 -> LIE s -- Wanted; no dups; all dictionaries, all
443 -- constraining just a type variable
444 -> NF_TcM s (Bag (TcIdOcc s,TcExpr s), -- Bindings
445 LIE s) -- Minimal wanted set
447 elimSCs givens wanteds
448 = -- Sort the wanteds so that subclasses occur before superclasses
450 (filterBag isDict givens) -- Filter out non-dictionaries
453 elimSCs_help :: LIE s -- Given; no dups
454 -> [Inst s] -- Wanted; no dups;
455 -> NF_TcM s (Bag (TcIdOcc s, TcExpr s), -- Bindings
456 LIE s) -- Minimal wanted set
458 elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
460 elimSCs_help givens (wanted:wanteds)
461 = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
462 elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
463 returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
466 trySC :: LIE s -- Givens
468 -> NF_TcM s (LIE s, -- New givens,
469 Bag (TcIdOcc s,TcExpr s), -- Bindings
470 LIE s) -- Irreducible wanted set
472 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
473 | not (maybeToBool maybe_best_subclass_chain)
474 = -- No superclass relationship
475 returnNF_Tc (givens, emptyBag, unitLIE wanted)
478 = -- There's a subclass relationship with a "given"
479 -- Build intermediate dictionaries
481 theta = [ (clas, wanted_ty) | clas <- reverse classes ]
482 -- The reverse is because the list comes back in the "wrong" order I think
484 newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) ->
486 -- Create bindings for the wanted dictionary and the intermediates.
487 -- Later binds may depend on earlier ones, so each new binding is pushed
488 -- on the front of the accumulating parameter list of bindings
490 mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
491 = ((dict_sub, dict_sub_class),
492 (instToId dict, DictApp (TyApp (HsVar (RealId (getSuperDictSelId dict_sub_class
495 [instToId dict_sub]))
496 (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
498 returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
503 maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
504 Just (given, classes, _) = maybe_best_subclass_chain
506 choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1
508 choose_best Nothing c2 = c2
509 choose_best c1 Nothing = c1
511 find_subclass_chain given@(Dict _ given_class given_ty _ _)
512 | wanted_ty `eqSimpleTy` given_ty
513 = case (wanted_class `isSuperClassOf` given_class) of
515 Just classes -> Just (given,
521 | otherwise = Nothing
524 sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of
525 -- which constrain type variables
526 -> [Inst s] -- Sorted with subclasses before superclasses
528 sortSC dicts = sortLt lt (bagToList dicts)
530 (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
531 = if ty1 `eqSimpleTy` ty2 then
532 maybeToBool (c2 `isSuperClassOf` c1)
534 -- order is immaterial, I think...
539 %************************************************************************
541 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
543 %************************************************************************
545 When doing a binding group, we may have @Insts@ of local functions.
546 For example, we might have...
548 let f x = x + 1 -- orig local function (overloaded)
549 f.1 = f Int -- two instances of f
554 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
555 where @f@ is in scope; those @Insts@ must certainly not be passed
556 upwards towards the top-level. If the @Insts@ were binding-ified up
557 there, they would have unresolvable references to @f@.
559 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
560 For each method @Inst@ in the @init_lie@ that mentions one of the
561 @Ids@, we create a binding. We return the remaining @Insts@ (in an
562 @LIE@), as well as the @HsBinds@ generated.
565 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
567 bindInstsOfLocalFuns init_lie local_ids
568 = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
570 bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
571 | id `is_elem` local_ids
572 = lookupInst inst `thenTc` \ (dict_insts, (id,rhs)) ->
573 returnTc (listToBag dict_insts `plusLIE` insts,
574 VarMonoBind id rhs `AndMonoBinds` binds)
576 bind_inst some_other_inst (insts, binds)
577 -- Either not a method, or a method instance for an id not in local_ids
578 = returnTc (some_other_inst `consBag` insts, binds)
580 is_elem = isIn "bindInstsOfLocalFuns"
584 %************************************************************************
586 \section[Disambig]{Disambiguation of overloading}
588 %************************************************************************
591 If a dictionary constrains a type variable which is
594 not mentioned in the environment
596 and not mentioned in the type of the expression
598 then it is ambiguous. No further information will arise to instantiate
599 the type variable; nor will it be generalised and turned into an extra
600 parameter to a function.
602 It is an error for this to occur, except that Haskell provided for
603 certain rules to be applied in the special case of numeric types.
608 at least one of its classes is a numeric class, and
610 all of its classes are numeric or standard
612 then the type variable can be defaulted to the first type in the
613 default-type list which is an instance of all the offending classes.
615 So here is the function which does the work. It takes the ambiguous
616 dictionaries and either resolves them (producing bindings) or
617 complains. It works by splitting the dictionary list by type
618 variable, and using @disambigOne@ to do the real business.
620 IMPORTANT: @disambiguate@ assumes that its argument dictionaries
621 constrain only a simple type variable.
624 type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
626 disambiguateDicts :: LIE s -> TcM s ()
628 disambiguateDicts insts
629 = mapTc disambigOne inst_infos `thenTc` \ binds_lists ->
632 inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
633 (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
635 mk_inst_info dict@(Dict _ clas ty _ _)
636 = (dict, clas, getTyVar "disambiguateDicts" ty)
639 @disambigOne@ assumes that its arguments dictionaries constrain all
640 the same type variable.
642 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
643 @()@ instead of @Int@. I reckon this is the Right Thing to do since
644 the most common use of defaulting is code like:
646 _ccall_ foo `seqPrimIO` bar
648 Since we're not using the result of @foo@, the result if (presumably)
650 WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
654 disambigOne :: [SimpleDictInfo s] -> TcM s ()
656 disambigOne dict_infos
657 | not (isStandardNumericDefaultable classes)
658 = failTc (ambigErr dicts) -- no default
660 | otherwise -- isStandardNumericDefaultable dict_infos
661 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
662 -- SO, TRY DEFAULT TYPES IN ORDER
664 -- Failure here is caused by there being no type in the
665 -- default list which can satisfy all the ambiguous classes.
666 -- For example, if Real a is reqd, but the only type in the
667 -- default list is Int.
668 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
670 try_default [] -- No defaults work, so fail
671 = failTc (defaultErr dicts default_tys)
673 try_default (default_ty : default_tys)
674 = tryTc (try_default default_tys) $ -- If default_ty fails, we try
675 -- default_tys instead
676 tcSimplifyCheckThetas DefaultDeclOrigin thetas `thenTc` \ _ ->
679 thetas = classes `zip` repeat default_ty
681 -- See if any default works, and if so bind the type variable to it
682 try_default default_tys `thenTc` \ chosen_default_ty ->
683 tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
684 unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
687 (_,_,tyvar) = head dict_infos -- Should be non-empty
688 dicts = [dict | (dict,_,_) <- dict_infos]
689 classes = [clas | (_,clas,_) <- dict_infos]
693 @isStandardNumericDefaultable@ sees whether the dicts have the
694 property required for defaulting; namely at least one is numeric, and
695 all are standard; or all are CcallIsh.
698 isStandardNumericDefaultable :: [Class] -> Bool
700 isStandardNumericDefaultable classes
701 | any isNumericClass classes && all isStandardClass classes
704 isStandardNumericDefaultable classes
705 | all isCcallishClass classes
708 isStandardNumericDefaultable classes
716 ToDo: for these error messages, should we note the location as coming
717 from the insts, or just whatever seems to be around in the monad just
721 genCantGenErr insts sty -- Can't generalise these Insts
722 = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):")
723 4 (ppAboves (map (ppr sty) (bagToList insts)))
728 = ppHang (ppStr "Ambiguous overloading")
729 4 (ppAboves (map (ppr sty) insts))
732 @reduceErr@ complains if we can't express required dictionaries in
733 terms of the signature.
737 = ppHang (ppStr "Type signature lacks context required by inferred type")
738 4 (ppHang (ppStr "Context reqd: ")
739 4 (ppAboves (map (ppr sty) (bagToList insts)))
744 defaultErr dicts defaulting_tys sty
745 = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
747 ppHang (ppStr "Conflicting:")
748 4 (ppInterleave ppSemi (map (ppr sty) dicts)),
749 ppHang (ppStr "Defaulting types :")
750 4 (ppr sty defaulting_tys),
751 ppStr "([Int, Double] is the default list of defaulting types.)" ])