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, Qualifier, HsType, ArithSeqInfo, Fixity,
19 GRHSsAndBinds, Stmt, Fake )
20 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
23 import Inst ( lookupInst, lookupSimpleInst,
24 tyVarsOfInst, isTyVarDict, isDict,
25 matchesInst, instToId, instBindingRequired,
26 instCanBeGeneralised, newDictsAtLoc,
28 Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE,
29 plusLIE, unitLIE, consLIE, InstOrigin(..),
31 import TcEnv ( tcGetGlobalTyVars )
32 import SpecEnv ( SpecEnv )
33 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
34 import Unify ( unifyTauTy )
36 import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
37 snocBag, consBag, unionBags, isEmptyBag )
38 import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
39 isSuperClassOf, classSuperDictSelId, classInstEnv
42 import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass )
44 import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
45 import Outputable ( Outputable(..){-instance * []-} )
46 --import PprStyle--ToDo:rm
47 import PprType ( GenType, GenTyVar )
49 import SrcLoc ( noSrcLoc )
50 import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
52 import TysWiredIn ( intTy, unitTy )
53 import TyVar ( GenTyVar, SYN_IE(GenTyVarSet),
54 elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
55 isEmptyTyVarSet, tyVarSetToList )
56 import Unique ( Unique )
61 %************************************************************************
63 \subsection[tcSimplify-main]{Main entry function}
65 %************************************************************************
67 * May modify the substitution to bind ambiguous type variables.
71 (1) If an inst constrains only ``global'' type variables, (or none),
72 return it as a ``global'' inst.
76 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
77 constraining only a type variable.
79 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
80 Otherwise it must be ambiguous, so try to resolve the ambiguity.
84 tcSimpl :: Bool -- True <=> simplify const insts
85 -> TcTyVarSet s -- ``Global'' type variables
86 -> TcTyVarSet s -- ``Local'' type variables
87 -- ASSERT: both these tyvar sets are already zonked
88 -> LIE s -- Given; these constrain only local tyvars
90 -> TcM s (LIE s, -- Free
91 [(TcIdOcc s,TcExpr s)], -- Bindings
92 LIE s) -- Remaining wanteds; no dups
94 tcSimpl squash_consts global_tvs local_tvs givens wanteds
95 = -- ASSSERT: global_tvs and local_tvs are already zonked
96 -- Make sure the insts fixed points of the substitution
97 zonkLIE givens `thenNF_Tc` \ givens ->
98 zonkLIE wanteds `thenNF_Tc` \ wanteds ->
100 -- Deal with duplicates and type constructors
102 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
103 givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
105 -- Now disambiguate if necessary
107 ambigs = filterBag is_ambiguous locals_and_ambigs
109 if not (isEmptyBag ambigs) then
110 -- Some ambiguous dictionaries. We now disambiguate them,
111 -- which binds the offending type variables to suitable types in the
112 -- substitution, and then we retry the whole process. This
113 -- time there won't be any ambiguous ones.
114 -- There's no need to back-substitute on global and local tvs,
115 -- because the ambiguous type variables can't be in either.
117 -- Why do we retry the whole process? Because binding a type variable
118 -- to a particular type might enable a short-cut simplification which
119 -- elimTyCons will have missed the first time.
121 disambiguateDicts ambigs `thenTc_`
122 tcSimpl squash_consts global_tvs local_tvs givens wanteds
125 -- No ambiguous dictionaries. Just bash on with the results
128 -- Check for non-generalisable insts
130 locals = locals_and_ambigs -- ambigs is empty
131 cant_generalise = filterBag (not . instCanBeGeneralised) locals
133 checkTc (isEmptyBag cant_generalise)
134 (genCantGenErr cant_generalise) `thenTc_`
137 -- Deal with superclass relationships
138 elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) ->
141 returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
143 is_ambiguous (Dict _ _ ty _ _)
144 = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
147 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
148 the ``don't-squash-consts'' flag set depending on top-level ness. For
149 top level defns we *do* squash constants, so that they stay local to a
150 single defn. This makes things which are inlined more likely to be
151 exportable, because their constants are "inside". Later passes will
152 float them out if poss, after inlinings are sorted out.
156 :: TcTyVarSet s -- ``Local'' type variables
158 -> TcM s (LIE s, -- Free
159 [(TcIdOcc s,TcExpr s)], -- Bindings
160 LIE s) -- Remaining wanteds; no dups
162 tcSimplify local_tvs wanteds
163 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
164 tcSimpl False global_tvs local_tvs emptyBag wanteds
167 @tcSimplifyAndCheck@ is similar to the above, except that it checks
168 that there is an empty wanted-set at the end. It may still return
169 some of constant insts, which have to be resolved finally at the end.
173 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
176 -> TcM s (LIE s, -- Free
177 [(TcIdOcc s,TcExpr s)]) -- Bindings
179 tcSimplifyAndCheck local_tvs givens wanteds
180 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
181 tcSimpl False global_tvs local_tvs
182 givens wanteds `thenTc` \ (free_insts, binds, wanteds') ->
183 checkTc (isEmptyBag wanteds')
184 (reduceErr wanteds') `thenTc_`
185 returnTc (free_insts, binds)
188 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
192 tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
194 -> TcM s (LIE s, -- Free
195 [(TcIdOcc s,TcExpr s)]) -- Bindings
198 tcSimplifyRank2 local_tvs givens
199 = zonkLIE givens `thenNF_Tc` \ givens' ->
201 (\tv -> not (tv `elementOfTyVarSet` local_tvs))
202 -- This predicate claims that all
203 -- any non-local tyvars are global,
204 -- thereby postponing dealing with
205 -- ambiguity until the enclosing Gen
206 emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
208 checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_`
210 returnTc (free, bagToList dict_binds)
213 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
214 mechansim with the extra flag to say ``beat out constant insts''.
217 tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
219 = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) ->
223 %************************************************************************
225 \subsection[elimTyCons]{@elimTyCons@}
227 %************************************************************************
230 elimTyCons :: Bool -- True <=> Simplify const insts
231 -> (TcTyVar s -> Bool) -- Free tyvar predicate
234 -> TcM s (LIE s, -- Free
235 Bag (TcIdOcc s, TcExpr s), -- Bindings
236 LIE s -- Remaining wanteds; no dups;
237 -- dicts only (no Methods)
241 The bindings returned may mention any or all of ``givens'', so the
242 order in which the generated binds are put together is {\em tricky}.
243 Case~4 of @try@ is the general case to see.
245 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
247 (1) first look up @wanted@; this gives us one binding to heave in:
250 (2) step (1) also gave us some @simpler_wanteds@; we simplify
251 these and get some (simpler-wanted-)bindings {\em that must be
252 in scope} for the @wanted=rhs@ binding above!
254 (3) we simplify the remaining @wanteds@ (recursive call), giving
255 us yet more bindings.
257 The final arrangement of the {\em non-recursive} bindings is
259 let <simpler-wanted-binds> in
261 let <yet-more-bindings> ...
264 elimTyCons squash_consts is_free_tv givens wanteds
265 = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) ->
266 returnTc (free,binds,irreds)
268 -- eTC :: LIE s -> [Inst s]
269 -- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
271 eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
273 eTC givens (wanted:wanteds)
274 -- Case 0: same as an existing inst
275 | maybeToBool maybe_equiv
276 = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
278 -- Create a new binding iff it's needed
279 this = expectJust "eTC" maybe_equiv
280 new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
284 returnTc (givens1, frees, new_binds, irreds)
286 -- Case 1: constrains no type variables at all
287 -- In this case we have a quick go to see if it has an
288 -- instance which requires no inputs (ie a constant); if so we use
289 -- it; if not, we give up on the instance and just heave it out the
290 -- top in the free result
291 | isEmptyTyVarSet tvs_of_wanted
292 = simplify_it squash_consts {- If squash_consts is false,
293 simplify only if trival -}
294 givens wanted wanteds
296 -- Case 2: constrains free vars only, so fling it out the top in free_ids
297 | all is_free_tv (tyVarSetToList tvs_of_wanted)
298 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
299 returnTc (givens1, wanted `consBag` frees, binds, irreds)
301 -- Case 3: is a dict constraining only a tyvar,
302 -- so return it as part of the "wanteds" result
304 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
305 returnTc (givens1, frees, binds, wanted `consBag` irreds)
307 -- Case 4: is not a simple dict, so look up in instance environment
309 = simplify_it True {- Simplify even if not trivial -}
310 givens wanted wanteds
312 tvs_of_wanted = tyVarsOfInst wanted
314 -- Look for something in "givens" that matches "wanted"
315 Just the_equiv = maybe_equiv
316 maybe_equiv = foldBag seqMaybe try Nothing givens
317 try given | wanted `matchesInst` given = Just given
318 | otherwise = Nothing
321 simplify_it simplify_always givens wanted wanteds
322 -- Recover immediately on no-such-instance errors
323 = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE))
324 (simplify_one simplify_always givens wanted)
325 `thenTc` \ (givens1, frees1, binds1, irreds1) ->
326 eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
327 returnTc (givens2, frees1 `plusLIE` frees2,
328 binds1 `unionBags` binds2,
329 irreds1 `plusLIE` irreds2)
332 simplify_one simplify_always givens wanted
333 | not (instBindingRequired wanted)
334 = -- No binding required for this chap, so squash right away
335 lookupInst wanted `thenTc` \ (simpler_wanteds, _) ->
336 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
337 returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
340 = -- An binding is required for this inst
341 lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
343 if (not_var rhs && not simplify_always) then
344 -- Ho ho! It isn't trivial to simplify "wanted",
345 -- because the rhs isn't a simple variable. Unless the flag
346 -- simplify_always is set, just give up now and
347 -- just fling it out the top.
348 returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
350 -- Aha! Either it's easy, or simplify_always is True
351 -- so we must do it right here.
352 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
353 returnTc (wanted `consLIE` givens1, frees1,
354 binds1 `snocBag` bind,
357 not_var :: TcExpr s -> Bool
358 not_var (HsVar _) = False
363 %************************************************************************
365 \subsection[elimSCs]{@elimSCs@}
367 %************************************************************************
370 elimSCs :: LIE s -- Given; no dups
371 -> LIE s -- Wanted; no dups; all dictionaries, all
372 -- constraining just a type variable
373 -> NF_TcM s (Bag (TcIdOcc s,TcExpr s), -- Bindings
374 LIE s) -- Minimal wanted set
376 elimSCs givens wanteds
377 = -- Sort the wanteds so that subclasses occur before superclasses
379 (filterBag isDict givens) -- Filter out non-dictionaries
382 elimSCs_help :: LIE s -- Given; no dups
383 -> [Inst s] -- Wanted; no dups;
384 -> NF_TcM s (Bag (TcIdOcc s, TcExpr s), -- Bindings
385 LIE s) -- Minimal wanted set
387 elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
389 elimSCs_help givens (wanted:wanteds)
390 = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
391 elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
392 returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
395 trySC :: LIE s -- Givens
397 -> NF_TcM s (LIE s, -- New givens,
398 Bag (TcIdOcc s,TcExpr s), -- Bindings
399 LIE s) -- Irreducible wanted set
401 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
402 | not (maybeToBool maybe_best_subclass_chain)
403 = -- No superclass relationship
404 returnNF_Tc (givens, emptyBag, unitLIE wanted)
407 = -- There's a subclass relationship with a "given"
408 -- Build intermediate dictionaries
410 theta = [ (clas, wanted_ty) | clas <- reverse classes ]
411 -- The reverse is because the list comes back in the "wrong" order I think
413 newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) ->
415 -- Create bindings for the wanted dictionary and the intermediates.
416 -- Later binds may depend on earlier ones, so each new binding is pushed
417 -- on the front of the accumulating parameter list of bindings
419 mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
420 = ((dict_sub, dict_sub_class),
421 (instToId dict, DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class
424 [instToId dict_sub]))
425 (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
427 returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
432 maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
433 Just (given, classes, _) = maybe_best_subclass_chain
435 choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1
437 choose_best Nothing c2 = c2
438 choose_best c1 Nothing = c1
440 find_subclass_chain given@(Dict _ given_class given_ty _ _)
441 | wanted_ty `eqSimpleTy` given_ty
442 = case (wanted_class `isSuperClassOf` given_class) of
444 Just classes -> Just (given,
450 | otherwise = Nothing
453 sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of
454 -- which constrain type variables
455 -> [Inst s] -- Sorted with subclasses before superclasses
457 sortSC dicts = sortLt lt (bagToList dicts)
459 (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
460 = if ty1 `eqSimpleTy` ty2 then
461 maybeToBool (c2 `isSuperClassOf` c1)
463 -- Order is immaterial, I think...
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, (id,rhs)) ->
582 returnTc (listToBag dict_insts `plusLIE` insts,
583 VarMonoBind id rhs `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 = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):")
716 4 (ppAboves (map (ppr sty) (bagToList insts)))
721 = ppAboves (map (pprInst sty "Ambiguous overloading") insts)
724 @reduceErr@ complains if we can't express required dictionaries in
725 terms of the signature.
729 = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature")