2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcSimplify]{TcSimplify}
7 #include "HsVersions.h"
10 tcSimplify, tcSimplifyAndCheck,
11 tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
17 import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
18 Match, HsBinds, HsType, ArithSeqInfo, Fixity,
19 GRHSsAndBinds, Stmt, DoOrListComp, Fake )
20 import HsBinds ( andMonoBinds )
21 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
22 SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )
25 import Inst ( lookupInst, lookupSimpleInst,
26 tyVarsOfInst, isTyVarDict, isDict,
27 matchesInst, instToId, instBindingRequired,
28 instCanBeGeneralised, newDictsAtLoc,
30 Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, pprLIE, pprLIEInFull,
31 plusLIE, unitLIE, consLIE, InstOrigin(..),
33 import TcEnv ( tcGetGlobalTyVars )
34 import SpecEnv ( SpecEnv )
35 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
36 import Unify ( unifyTauTy )
38 import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
39 snocBag, consBag, unionBags, isEmptyBag )
40 import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
41 isSuperClassOf, classSuperDictSelId, classInstEnv
44 import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass )
46 import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
47 import Outputable ( PprStyle, Outputable(..){-instance * []-} )
48 import PprType ( GenType, GenTyVar )
50 import SrcLoc ( noSrcLoc )
51 import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
53 import TysWiredIn ( intTy, unitTy )
54 import TyVar ( GenTyVar, SYN_IE(GenTyVarSet),
55 elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
56 isEmptyTyVarSet, tyVarSetToList )
57 import Unique ( Unique )
62 %************************************************************************
64 \subsection[tcSimplify-main]{Main entry function}
66 %************************************************************************
68 * May modify the substitution to bind ambiguous type variables.
72 (1) If an inst constrains only ``global'' type variables, (or none),
73 return it as a ``global'' inst.
77 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
78 constraining only a type variable.
80 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
81 Otherwise it must be ambiguous, so try to resolve the ambiguity.
85 tcSimpl :: Bool -- True <=> simplify const insts
86 -> TcTyVarSet s -- ``Global'' type variables
87 -> TcTyVarSet s -- ``Local'' type variables
88 -- ASSERT: both these tyvar sets are already zonked
89 -> LIE s -- Given; these constrain only local tyvars
91 -> TcM s (LIE s, -- Free
92 TcMonoBinds s, -- Bindings
93 LIE s) -- Remaining wanteds; no dups
95 tcSimpl squash_consts global_tvs local_tvs givens wanteds
96 = -- ASSSERT: global_tvs and local_tvs are already zonked
97 -- Make sure the insts fixed points of the substitution
98 zonkLIE givens `thenNF_Tc` \ givens ->
99 zonkLIE wanteds `thenNF_Tc` \ wanteds ->
101 -- Deal with duplicates and type constructors
103 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
104 givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
106 -- Now disambiguate if necessary
108 ambigs = filterBag is_ambiguous locals_and_ambigs
110 if not (isEmptyBag ambigs) then
111 -- Some ambiguous dictionaries. We now disambiguate them,
112 -- which binds the offending type variables to suitable types in the
113 -- substitution, and then we retry the whole process. This
114 -- time there won't be any ambiguous ones.
115 -- There's no need to back-substitute on global and local tvs,
116 -- because the ambiguous type variables can't be in either.
118 -- Why do we retry the whole process? Because binding a type variable
119 -- to a particular type might enable a short-cut simplification which
120 -- elimTyCons will have missed the first time.
122 disambiguateDicts ambigs `thenTc_`
123 tcSimpl squash_consts global_tvs local_tvs givens wanteds
126 -- No ambiguous dictionaries. Just bash on with the results
129 -- Check for non-generalisable insts
131 locals = locals_and_ambigs -- ambigs is empty
132 cant_generalise = filterBag (not . instCanBeGeneralised) locals
134 checkTc (isEmptyBag cant_generalise)
135 (genCantGenErr cant_generalise) `thenTc_`
138 -- Deal with superclass relationships
139 elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) ->
142 returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2)
144 is_ambiguous (Dict _ _ ty _ _)
145 = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
148 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
149 the ``don't-squash-consts'' flag set depending on top-level ness. For
150 top level defns we *do* squash constants, so that they stay local to a
151 single defn. This makes things which are inlined more likely to be
152 exportable, because their constants are "inside". Later passes will
153 float them out if poss, after inlinings are sorted out.
157 :: TcTyVarSet s -- ``Local'' type variables
159 -> TcM s (LIE s, -- Free
160 TcDictBinds s, -- Bindings
161 LIE s) -- Remaining wanteds; no dups
163 tcSimplify local_tvs wanteds
164 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
165 tcSimpl False global_tvs local_tvs emptyBag wanteds
168 @tcSimplifyAndCheck@ is similar to the above, except that it checks
169 that there is an empty wanted-set at the end. It may still return
170 some of constant insts, which have to be resolved finally at the end.
174 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
177 -> TcM s (LIE s, -- Free
178 TcDictBinds s) -- Bindings
180 tcSimplifyAndCheck local_tvs givens wanteds
181 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
182 tcSimpl False global_tvs local_tvs
183 givens wanteds `thenTc` \ (free_insts, binds, wanteds') ->
184 checkTc (isEmptyBag wanteds')
185 (reduceErr wanteds') `thenTc_`
186 returnTc (free_insts, binds)
189 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
193 tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
195 -> TcM s (LIE s, -- Free
196 TcDictBinds s) -- Bindings
199 tcSimplifyRank2 local_tvs givens
200 = zonkLIE givens `thenNF_Tc` \ givens' ->
202 (\tv -> not (tv `elementOfTyVarSet` local_tvs))
203 -- This predicate claims that all
204 -- any non-local tyvars are global,
205 -- thereby postponing dealing with
206 -- ambiguity until the enclosing Gen
207 emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
209 checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_`
211 returnTc (free, dict_binds)
214 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
215 mechansim with the extra flag to say ``beat out constant insts''.
218 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
220 = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) ->
224 %************************************************************************
226 \subsection[elimTyCons]{@elimTyCons@}
228 %************************************************************************
231 elimTyCons :: Bool -- True <=> Simplify const insts
232 -> (TcTyVar s -> Bool) -- Free tyvar predicate
235 -> TcM s (LIE s, -- Free
236 TcDictBinds s, -- Bindings
237 LIE s -- Remaining wanteds; no dups;
238 -- dicts only (no Methods)
242 The bindings returned may mention any or all of ``givens'', so the
243 order in which the generated binds are put together is {\em tricky}.
244 Case~4 of @try@ is the general case to see.
246 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
248 (1) first look up @wanted@; this gives us one binding to heave in:
251 (2) step (1) also gave us some @simpler_wanteds@; we simplify
252 these and get some (simpler-wanted-)bindings {\em that must be
253 in scope} for the @wanted=rhs@ binding above!
255 (3) we simplify the remaining @wanteds@ (recursive call), giving
256 us yet more bindings.
258 The final arrangement of the {\em non-recursive} bindings is
260 let <simpler-wanted-binds> in
262 let <yet-more-bindings> ...
265 elimTyCons squash_consts is_free_tv givens wanteds
266 = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) ->
267 returnTc (free,binds,irreds)
269 -- eTC :: LIE s -> [Inst s]
270 -- -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s)
272 eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag)
274 eTC givens (wanted:wanteds)
275 -- Case 0: same as an existing inst
276 | maybeToBool maybe_equiv
277 = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
279 -- Create a new binding iff it's needed
280 this = expectJust "eTC" maybe_equiv
281 new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this)))
285 returnTc (givens1, frees, new_binds, irreds)
287 -- Case 1: constrains no type variables at all
288 -- In this case we have a quick go to see if it has an
289 -- instance which requires no inputs (ie a constant); if so we use
290 -- it; if not, we give up on the instance and just heave it out the
291 -- top in the free result
292 | isEmptyTyVarSet tvs_of_wanted
293 = simplify_it squash_consts {- If squash_consts is false,
294 simplify only if trival -}
295 givens wanted wanteds
297 -- Case 2: constrains free vars only, so fling it out the top in free_ids
298 | all is_free_tv (tyVarSetToList tvs_of_wanted)
299 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
300 returnTc (givens1, wanted `consBag` frees, binds, irreds)
302 -- Case 3: is a dict constraining only a tyvar,
303 -- so return it as part of the "wanteds" result
305 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
306 returnTc (givens1, frees, binds, wanted `consBag` irreds)
308 -- Case 4: is not a simple dict, so look up in instance environment
310 = simplify_it True {- Simplify even if not trivial -}
311 givens wanted wanteds
313 tvs_of_wanted = tyVarsOfInst wanted
315 -- Look for something in "givens" that matches "wanted"
316 Just the_equiv = maybe_equiv
317 maybe_equiv = foldBag seqMaybe try Nothing givens
318 try given | wanted `matchesInst` given = Just given
319 | otherwise = Nothing
322 simplify_it simplify_always givens wanted wanteds
323 -- Recover immediately on no-such-instance errors
324 = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE))
325 (simplify_one simplify_always givens wanted)
326 `thenTc` \ (givens1, frees1, binds1, irreds1) ->
327 eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
328 returnTc (givens2, frees1 `plusLIE` frees2,
329 binds1 `AndMonoBinds` binds2,
330 irreds1 `plusLIE` irreds2)
333 simplify_one simplify_always givens wanted
334 | not (instBindingRequired wanted)
335 = -- No binding required for this chap, so squash right away
336 lookupInst wanted `thenTc` \ (simpler_wanteds, _) ->
337 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
338 returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
341 = -- An binding is required for this inst
342 lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) ->
344 if (not_var rhs && not simplify_always) then
345 -- Ho ho! It isn't trivial to simplify "wanted",
346 -- because the rhs isn't a simple variable. Unless the flag
347 -- simplify_always is set, just give up now and
348 -- just fling it out the top.
349 returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE)
351 -- Aha! Either it's easy, or simplify_always is True
352 -- so we must do it right here.
353 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
354 returnTc (wanted `consLIE` givens1, frees1,
355 binds1 `AndMonoBinds` bind,
358 not_var :: TcExpr s -> Bool
359 not_var (HsVar _) = False
364 %************************************************************************
366 \subsection[elimSCs]{@elimSCs@}
368 %************************************************************************
371 elimSCs :: LIE s -- Given; no dups
372 -> LIE s -- Wanted; no dups; all dictionaries, all
373 -- constraining just a type variable
374 -> NF_TcM s (TcDictBinds s, -- Bindings
375 LIE s) -- Minimal wanted set
377 elimSCs givens wanteds
378 = -- Sort the wanteds so that subclasses occur before superclasses
380 (filterBag isDict givens) -- Filter out non-dictionaries
383 elimSCs_help :: LIE s -- Given; no dups
384 -> [Inst s] -- Wanted; no dups;
385 -> NF_TcM s (TcDictBinds s, -- Bindings
386 LIE s) -- Minimal wanted set
388 elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE)
390 elimSCs_help givens (wanted:wanteds)
391 = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
392 elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
393 returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2)
396 trySC :: LIE s -- Givens
398 -> NF_TcM s (LIE s, -- New givens,
399 TcDictBinds s, -- Bindings
400 LIE s) -- Irreducible wanted set
402 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
403 | not (maybeToBool maybe_best_subclass_chain)
404 = -- No superclass relationship
405 returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted)
408 = -- There's a subclass relationship with a "given"
409 -- Build intermediate dictionaries
411 theta = [ (clas, wanted_ty) | clas <- reverse classes ]
412 -- The reverse is because the list comes back in the "wrong" order I think
414 newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) ->
416 -- Create bindings for the wanted dictionary and the intermediates.
417 -- Later binds may depend on earlier ones, so each new binding is pushed
418 -- on the front of the accumulating parameter list of bindings
420 mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
421 = ((dict_sub, dict_sub_class),
422 (VarMonoBind (instToId dict)
423 (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class
426 [instToId dict_sub])))
427 (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
429 returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
430 andMonoBinds new_binds,
434 maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
435 Just (given, classes, _) = maybe_best_subclass_chain
437 choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1
439 choose_best Nothing c2 = c2
440 choose_best c1 Nothing = c1
442 find_subclass_chain given@(Dict _ given_class given_ty _ _)
443 | wanted_ty `eqSimpleTy` given_ty
444 = case (wanted_class `isSuperClassOf` given_class) of
446 Just classes -> Just (given,
452 | otherwise = Nothing
455 sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of
456 -- which constrain type variables
457 -> [Inst s] -- Sorted with subclasses before superclasses
459 sortSC dicts = sortLt lt (bagToList dicts)
461 (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
462 = maybeToBool (c2 `isSuperClassOf` c1)
463 -- The ice is a bit thin here because this "lt" isn't a total order
464 -- But it *is* transitive, so it works ok
468 %************************************************************************
470 \subsection[simple]{@Simple@ versions}
472 %************************************************************************
474 Much simpler versions when there are no bindings to make!
476 @tcSimplifyThetas@ simplifies class-type constraints formed by
477 @deriving@ declarations and when specialising instances. We are
478 only interested in the simplified bunch of class/type constraints.
481 tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
482 -> [(Class, TauType)] -- Given
483 -> [(Class, TauType)] -- Wanted
484 -> TcM s [(Class, TauType)]
487 tcSimplifyThetas inst_mapper given wanted
488 = elimTyConsSimple inst_mapper wanted `thenTc` \ wanted1 ->
489 returnTc (elimSCsSimple given wanted1)
492 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
493 used with \tr{default} declarations. We are only interested in
494 whether it worked or not.
497 tcSimplifyCheckThetas :: [(Class, TauType)] -- Simplify this to nothing at all
500 tcSimplifyCheckThetas theta
501 = elimTyConsSimple classInstEnv theta `thenTc` \ theta1 ->
502 ASSERT( null theta1 )
508 elimTyConsSimple :: (Class -> ClassInstEnv)
510 -> TcM s [(Class,Type)]
511 elimTyConsSimple inst_mapper theta
514 elim [] = returnTc []
515 elim ((clas,ty):rest) = elim_one clas ty `thenTc` \ r1 ->
516 elim rest `thenTc` \ r2 ->
520 = case getTyVar_maybe ty of
522 Just tv -> returnTc [(clas,ty)]
524 otherwise -> recoverTc (returnTc []) $
525 lookupSimpleInst (inst_mapper clas) clas ty `thenTc` \ theta ->
528 elimSCsSimple :: [(Class,Type)] -- Given
529 -> [(Class,Type)] -- Wanted
530 -> [(Class,Type)] -- Subset of wanted; no dups, no subclass relnships
532 elimSCsSimple givens [] = []
533 elimSCsSimple givens (c_t@(clas,ty) : rest)
534 | any (`subsumes` c_t) givens ||
535 any (`subsumes` c_t) rest -- (clas,ty) is old hat
536 = elimSCsSimple givens rest
537 | otherwise -- (clas,ty) is new
538 = c_t : elimSCsSimple (c_t : givens) rest
540 rest' = elimSCsSimple rest
541 (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 &&
542 (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
543 -- We deal with duplicates here ^^^^^^^^
544 -- It's a simple place to do it, although it's done in elimTyCons in the
545 -- full-blown version of the simpifier.
548 %************************************************************************
550 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
552 %************************************************************************
554 When doing a binding group, we may have @Insts@ of local functions.
555 For example, we might have...
557 let f x = x + 1 -- orig local function (overloaded)
558 f.1 = f Int -- two instances of f
563 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
564 where @f@ is in scope; those @Insts@ must certainly not be passed
565 upwards towards the top-level. If the @Insts@ were binding-ified up
566 there, they would have unresolvable references to @f@.
568 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
569 For each method @Inst@ in the @init_lie@ that mentions one of the
570 @Ids@, we create a binding. We return the remaining @Insts@ (in an
571 @LIE@), as well as the @HsBinds@ generated.
574 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
576 bindInstsOfLocalFuns init_lie local_ids
577 = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
579 bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
580 | id `is_elem` local_ids
581 = lookupInst inst `thenTc` \ (dict_insts, bind) ->
582 returnTc (listToBag dict_insts `plusLIE` insts,
583 bind `AndMonoBinds` binds)
585 bind_inst some_other_inst (insts, binds)
586 -- Either not a method, or a method instance for an id not in local_ids
587 = returnTc (some_other_inst `consBag` insts, binds)
589 is_elem = isIn "bindInstsOfLocalFuns"
593 %************************************************************************
595 \section[Disambig]{Disambiguation of overloading}
597 %************************************************************************
600 If a dictionary constrains a type variable which is
603 not mentioned in the environment
605 and not mentioned in the type of the expression
607 then it is ambiguous. No further information will arise to instantiate
608 the type variable; nor will it be generalised and turned into an extra
609 parameter to a function.
611 It is an error for this to occur, except that Haskell provided for
612 certain rules to be applied in the special case of numeric types.
617 at least one of its classes is a numeric class, and
619 all of its classes are numeric or standard
621 then the type variable can be defaulted to the first type in the
622 default-type list which is an instance of all the offending classes.
624 So here is the function which does the work. It takes the ambiguous
625 dictionaries and either resolves them (producing bindings) or
626 complains. It works by splitting the dictionary list by type
627 variable, and using @disambigOne@ to do the real business.
629 IMPORTANT: @disambiguate@ assumes that its argument dictionaries
630 constrain only a simple type variable.
633 type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
635 disambiguateDicts :: LIE s -> TcM s ()
637 disambiguateDicts insts
638 = mapTc disambigOne inst_infos `thenTc` \ binds_lists ->
641 inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
642 (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
644 mk_inst_info dict@(Dict _ clas ty _ _)
645 = (dict, clas, getTyVar "disambiguateDicts" ty)
648 @disambigOne@ assumes that its arguments dictionaries constrain all
649 the same type variable.
651 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
652 @()@ instead of @Int@. I reckon this is the Right Thing to do since
653 the most common use of defaulting is code like:
655 _ccall_ foo `seqPrimIO` bar
657 Since we're not using the result of @foo@, the result if (presumably)
661 disambigOne :: [SimpleDictInfo s] -> TcM s ()
663 disambigOne dict_infos
664 | any isNumericClass classes && all isStandardClass classes
665 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
666 -- SO, TRY DEFAULT TYPES IN ORDER
668 -- Failure here is caused by there being no type in the
669 -- default list which can satisfy all the ambiguous classes.
670 -- For example, if Real a is reqd, but the only type in the
671 -- default list is Int.
672 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
674 try_default [] -- No defaults work, so fail
675 = failTc (ambigErr dicts)
677 try_default (default_ty : default_tys)
678 = tryTc (try_default default_tys) $ -- If default_ty fails, we try
679 -- default_tys instead
680 tcSimplifyCheckThetas thetas `thenTc` \ _ ->
683 thetas = classes `zip` repeat default_ty
685 -- See if any default works, and if so bind the type variable to it
686 try_default default_tys `thenTc` \ chosen_default_ty ->
687 tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
688 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
690 | all isCcallishClass classes
691 = -- Default CCall stuff to (); we don't even both to check that () is an
692 -- instance of CCallable/CReturnable, because we know it is.
693 unifyTauTy (mkTyVarTy tyvar) unitTy
695 | otherwise -- No defaults
696 = failTc (ambigErr dicts)
699 (_,_,tyvar) = head dict_infos -- Should be non-empty
700 dicts = [dict | (dict,_,_) <- dict_infos]
701 classes = [clas | (_,clas,_) <- dict_infos]
709 ToDo: for these error messages, should we note the location as coming
710 from the insts, or just whatever seems to be around in the monad just
714 genCantGenErr insts sty -- Can't generalise these Insts
715 = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"))
716 4 (vcat (map (ppr sty) (bagToList insts)))
721 = sep [text "Ambiguous context" <+> pprLIE sty lie,
722 nest 4 (pprLIEInFull sty lie)
725 lie = listToBag dicts -- Yuk
728 @reduceErr@ complains if we can't express required dictionaries in
729 terms of the signature.
733 = sep [text "Context" <+> pprLIE sty lie,
734 nest 4 (text "required by inferred type, but missing on a type signature"),
735 nest 4 (pprLIEInFull sty lie)