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, PolyType, ArithSeqInfo,
19 GRHSsAndBinds, Stmt, Fake )
20 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
22 import TcMonad hiding ( rnMtoTcM )
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 isNumericClass, isStandardClass, isCcallishClass,
40 isSuperClassOf, classSuperDictSelId, classInstEnv
43 import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
44 import Outputable ( Outputable(..){-instance * []-} )
45 --import PprStyle--ToDo:rm
46 import PprType ( GenType, GenTyVar )
48 import SrcLoc ( mkUnknownSrcLoc )
49 import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
51 import TysWiredIn ( intTy )
52 import TyVar ( GenTyVar, SYN_IE(GenTyVarSet),
53 elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
54 isEmptyTyVarSet, tyVarSetToList )
55 import Unique ( Unique )
60 %************************************************************************
62 \subsection[tcSimplify-main]{Main entry function}
64 %************************************************************************
66 * May modify the substitution to bind ambiguous type variables.
70 (1) If an inst constrains only ``global'' type variables, (or none),
71 return it as a ``global'' inst.
75 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
76 constraining only a type variable.
78 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
79 Otherwise it must be ambiguous, so try to resolve the ambiguity.
83 tcSimpl :: Bool -- True <=> simplify const insts
84 -> TcTyVarSet s -- ``Global'' type variables
85 -> TcTyVarSet s -- ``Local'' type variables
86 -- ASSERT: both these tyvar sets are already zonked
87 -> LIE s -- Given; these constrain only local tyvars
89 -> TcM s (LIE s, -- Free
90 [(TcIdOcc s,TcExpr s)], -- Bindings
91 LIE s) -- Remaining wanteds; no dups
93 tcSimpl squash_consts global_tvs local_tvs givens wanteds
94 = -- ASSSERT: global_tvs and local_tvs are already zonked
95 -- Make sure the insts fixed points of the substitution
96 zonkLIE givens `thenNF_Tc` \ givens ->
97 zonkLIE wanteds `thenNF_Tc` \ wanteds ->
99 -- Deal with duplicates and type constructors
101 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
102 givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
104 -- Now disambiguate if necessary
106 ambigs = filterBag is_ambiguous locals_and_ambigs
108 if not (isEmptyBag ambigs) then
109 -- Some ambiguous dictionaries. We now disambiguate them,
110 -- which binds the offending type variables to suitable types in the
111 -- substitution, and then we retry the whole process. This
112 -- time there won't be any ambiguous ones.
113 -- There's no need to back-substitute on global and local tvs,
114 -- because the ambiguous type variables can't be in either.
116 -- Why do we retry the whole process? Because binding a type variable
117 -- to a particular type might enable a short-cut simplification which
118 -- elimTyCons will have missed the first time.
120 disambiguateDicts ambigs `thenTc_`
121 tcSimpl squash_consts global_tvs local_tvs givens wanteds
124 -- No ambiguous dictionaries. Just bash on with the results
127 -- Check for non-generalisable insts
129 locals = locals_and_ambigs -- ambigs is empty
130 cant_generalise = filterBag (not . instCanBeGeneralised) locals
132 checkTc (isEmptyBag cant_generalise)
133 (genCantGenErr cant_generalise) `thenTc_`
136 -- Deal with superclass relationships
137 elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) ->
140 returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
142 is_ambiguous (Dict _ _ ty _ _)
143 = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
146 The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
147 the ``don't-squash-consts'' flag set depending on top-level ness. For
148 top level defns we *do* squash constants, so that they stay local to a
149 single defn. This makes things which are inlined more likely to be
150 exportable, because their constants are "inside". Later passes will
151 float them out if poss, after inlinings are sorted out.
155 :: TcTyVarSet s -- ``Local'' type variables
157 -> TcM s (LIE s, -- Free
158 [(TcIdOcc s,TcExpr s)], -- Bindings
159 LIE s) -- Remaining wanteds; no dups
161 tcSimplify local_tvs wanteds
162 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
163 tcSimpl False global_tvs local_tvs emptyBag wanteds
166 @tcSimplifyAndCheck@ is similar to the above, except that it checks
167 that there is an empty wanted-set at the end. It may still return
168 some of constant insts, which have to be resolved finally at the end.
172 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
175 -> TcM s (LIE s, -- Free
176 [(TcIdOcc s,TcExpr s)]) -- Bindings
178 tcSimplifyAndCheck local_tvs givens wanteds
179 = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
180 tcSimpl False global_tvs local_tvs
181 givens wanteds `thenTc` \ (free_insts, binds, wanteds') ->
182 checkTc (isEmptyBag wanteds')
183 (reduceErr wanteds') `thenTc_`
184 returnTc (free_insts, binds)
187 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
191 tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
193 -> TcM s (LIE s, -- Free
194 [(TcIdOcc s,TcExpr s)]) -- Bindings
197 tcSimplifyRank2 local_tvs givens
198 = zonkLIE givens `thenNF_Tc` \ givens' ->
200 (\tv -> not (tv `elementOfTyVarSet` local_tvs))
201 -- This predicate claims that all
202 -- any non-local tyvars are global,
203 -- thereby postponing dealing with
204 -- ambiguity until the enclosing Gen
205 emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
207 checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_`
209 returnTc (free, bagToList dict_binds)
212 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
213 mechansim with the extra flag to say ``beat out constant insts''.
216 tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
218 = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) ->
222 %************************************************************************
224 \subsection[elimTyCons]{@elimTyCons@}
226 %************************************************************************
229 elimTyCons :: Bool -- True <=> Simplify const insts
230 -> (TcTyVar s -> Bool) -- Free tyvar predicate
233 -> TcM s (LIE s, -- Free
234 Bag (TcIdOcc s, TcExpr s), -- Bindings
235 LIE s -- Remaining wanteds; no dups;
236 -- dicts only (no Methods)
240 The bindings returned may mention any or all of ``givens'', so the
241 order in which the generated binds are put together is {\em tricky}.
242 Case~4 of @try@ is the general case to see.
244 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
246 (1) first look up @wanted@; this gives us one binding to heave in:
249 (2) step (1) also gave us some @simpler_wanteds@; we simplify
250 these and get some (simpler-wanted-)bindings {\em that must be
251 in scope} for the @wanted=rhs@ binding above!
253 (3) we simplify the remaining @wanteds@ (recursive call), giving
254 us yet more bindings.
256 The final arrangement of the {\em non-recursive} bindings is
258 let <simpler-wanted-binds> in
260 let <yet-more-bindings> ...
263 elimTyCons squash_consts is_free_tv givens wanteds
264 = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) ->
265 returnTc (free,binds,irreds)
267 -- eTC :: LIE s -> [Inst s]
268 -- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
270 eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
272 eTC givens (wanted:wanteds)
273 -- Case 0: same as an existing inst
274 | maybeToBool maybe_equiv
275 = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
277 -- Create a new binding iff it's needed
278 this = expectJust "eTC" maybe_equiv
279 new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
283 returnTc (givens1, frees, new_binds, irreds)
285 -- Case 1: constrains no type variables at all
286 -- In this case we have a quick go to see if it has an
287 -- instance which requires no inputs (ie a constant); if so we use
288 -- it; if not, we give up on the instance and just heave it out the
289 -- top in the free result
290 | isEmptyTyVarSet tvs_of_wanted
291 = simplify_it squash_consts {- If squash_consts is false,
292 simplify only if trival -}
293 givens wanted wanteds
295 -- Case 2: constrains free vars only, so fling it out the top in free_ids
296 | all is_free_tv (tyVarSetToList tvs_of_wanted)
297 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
298 returnTc (givens1, wanted `consBag` frees, binds, irreds)
300 -- Case 3: is a dict constraining only a tyvar,
301 -- so return it as part of the "wanteds" result
303 = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
304 returnTc (givens1, frees, binds, wanted `consBag` irreds)
306 -- Case 4: is not a simple dict, so look up in instance environment
308 = simplify_it True {- Simplify even if not trivial -}
309 givens wanted wanteds
311 tvs_of_wanted = tyVarsOfInst wanted
313 -- Look for something in "givens" that matches "wanted"
314 Just the_equiv = maybe_equiv
315 maybe_equiv = foldBag seqMaybe try Nothing givens
316 try given | wanted `matchesInst` given = Just given
317 | otherwise = Nothing
320 simplify_it simplify_always givens wanted wanteds
321 -- Recover immediately on no-such-instance errors
322 = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE))
323 (simplify_one simplify_always givens wanted)
324 `thenTc` \ (givens1, frees1, binds1, irreds1) ->
325 eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
326 returnTc (givens2, frees1 `plusLIE` frees2,
327 binds1 `unionBags` binds2,
328 irreds1 `plusLIE` irreds2)
331 simplify_one simplify_always givens wanted
332 | not (instBindingRequired wanted)
333 = -- No binding required for this chap, so squash right away
334 lookupInst wanted `thenTc` \ (simpler_wanteds, _) ->
335 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
336 returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
339 = -- An binding is required for this inst
340 lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
342 if (not_var rhs && not simplify_always) then
343 -- Ho ho! It isn't trivial to simplify "wanted",
344 -- because the rhs isn't a simple variable. Unless the flag
345 -- simplify_always is set, just give up now and
346 -- just fling it out the top.
347 returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
349 -- Aha! Either it's easy, or simplify_always is True
350 -- so we must do it right here.
351 eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
352 returnTc (wanted `consLIE` givens1, frees1,
353 binds1 `snocBag` bind,
356 not_var :: TcExpr s -> Bool
357 not_var (HsVar _) = False
362 %************************************************************************
364 \subsection[elimSCs]{@elimSCs@}
366 %************************************************************************
369 elimSCs :: LIE s -- Given; no dups
370 -> LIE s -- Wanted; no dups; all dictionaries, all
371 -- constraining just a type variable
372 -> NF_TcM s (Bag (TcIdOcc s,TcExpr s), -- Bindings
373 LIE s) -- Minimal wanted set
375 elimSCs givens wanteds
376 = -- Sort the wanteds so that subclasses occur before superclasses
378 (filterBag isDict givens) -- Filter out non-dictionaries
381 elimSCs_help :: LIE s -- Given; no dups
382 -> [Inst s] -- Wanted; no dups;
383 -> NF_TcM s (Bag (TcIdOcc s, TcExpr s), -- Bindings
384 LIE s) -- Minimal wanted set
386 elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
388 elimSCs_help givens (wanted:wanteds)
389 = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
390 elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
391 returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
394 trySC :: LIE s -- Givens
396 -> NF_TcM s (LIE s, -- New givens,
397 Bag (TcIdOcc s,TcExpr s), -- Bindings
398 LIE s) -- Irreducible wanted set
400 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
401 | not (maybeToBool maybe_best_subclass_chain)
402 = -- No superclass relationship
403 returnNF_Tc (givens, emptyBag, unitLIE wanted)
406 = -- There's a subclass relationship with a "given"
407 -- Build intermediate dictionaries
409 theta = [ (clas, wanted_ty) | clas <- reverse classes ]
410 -- The reverse is because the list comes back in the "wrong" order I think
412 newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) ->
414 -- Create bindings for the wanted dictionary and the intermediates.
415 -- Later binds may depend on earlier ones, so each new binding is pushed
416 -- on the front of the accumulating parameter list of bindings
418 mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
419 = ((dict_sub, dict_sub_class),
420 (instToId dict, DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class
423 [instToId dict_sub]))
424 (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
426 returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
431 maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
432 Just (given, classes, _) = maybe_best_subclass_chain
434 choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1
436 choose_best Nothing c2 = c2
437 choose_best c1 Nothing = c1
439 find_subclass_chain given@(Dict _ given_class given_ty _ _)
440 | wanted_ty `eqSimpleTy` given_ty
441 = case (wanted_class `isSuperClassOf` given_class) of
443 Just classes -> Just (given,
449 | otherwise = Nothing
452 sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of
453 -- which constrain type variables
454 -> [Inst s] -- Sorted with subclasses before superclasses
456 sortSC dicts = sortLt lt (bagToList dicts)
458 (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
459 = if ty1 `eqSimpleTy` ty2 then
460 maybeToBool (c2 `isSuperClassOf` c1)
462 -- Order is immaterial, I think...
467 %************************************************************************
469 \subsection[simple]{@Simple@ versions}
471 %************************************************************************
473 Much simpler versions when there are no bindings to make!
475 @tcSimplifyThetas@ simplifies class-type constraints formed by
476 @deriving@ declarations and when specialising instances. We are
477 only interested in the simplified bunch of class/type constraints.
480 tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
481 -> [(Class, TauType)] -- Given
482 -> [(Class, TauType)] -- Wanted
483 -> TcM s [(Class, TauType)]
486 tcSimplifyThetas inst_mapper given wanted
487 = elimTyConsSimple inst_mapper wanted `thenTc` \ wanted1 ->
488 returnTc (elimSCsSimple given wanted1)
491 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
492 used with \tr{default} declarations. We are only interested in
493 whether it worked or not.
496 tcSimplifyCheckThetas :: [(Class, TauType)] -- Simplify this to nothing at all
499 tcSimplifyCheckThetas theta
500 = elimTyConsSimple classInstEnv theta `thenTc` \ theta1 ->
501 ASSERT( null theta1 )
507 elimTyConsSimple :: (Class -> ClassInstEnv)
509 -> TcM s [(Class,Type)]
510 elimTyConsSimple inst_mapper theta
513 elim [] = returnTc []
514 elim ((clas,ty):rest) = elim_one clas ty `thenTc` \ r1 ->
515 elim rest `thenTc` \ r2 ->
519 = case getTyVar_maybe ty of
521 Just tv -> returnTc [(clas,ty)]
523 otherwise -> recoverTc (returnTc []) $
524 lookupSimpleInst (inst_mapper clas) clas ty `thenTc` \ theta ->
527 elimSCsSimple :: [(Class,Type)] -- Given
528 -> [(Class,Type)] -- Wanted
529 -> [(Class,Type)] -- Subset of wanted; no dups, no subclass relnships
531 elimSCsSimple givens [] = []
532 elimSCsSimple givens (c_t@(clas,ty) : rest)
533 | any (`subsumes` c_t) givens ||
534 any (`subsumes` c_t) rest -- (clas,ty) is old hat
535 = elimSCsSimple givens rest
536 | otherwise -- (clas,ty) is new
537 = c_t : elimSCsSimple (c_t : givens) rest
539 rest' = elimSCsSimple rest
540 (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 &&
541 (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
542 -- We deal with duplicates here ^^^^^^^^
543 -- It's a simple place to do it, although it's done in elimTyCons in the
544 -- full-blown version of the simpifier.
547 %************************************************************************
549 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
551 %************************************************************************
553 When doing a binding group, we may have @Insts@ of local functions.
554 For example, we might have...
556 let f x = x + 1 -- orig local function (overloaded)
557 f.1 = f Int -- two instances of f
562 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
563 where @f@ is in scope; those @Insts@ must certainly not be passed
564 upwards towards the top-level. If the @Insts@ were binding-ified up
565 there, they would have unresolvable references to @f@.
567 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
568 For each method @Inst@ in the @init_lie@ that mentions one of the
569 @Ids@, we create a binding. We return the remaining @Insts@ (in an
570 @LIE@), as well as the @HsBinds@ generated.
573 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
575 bindInstsOfLocalFuns init_lie local_ids
576 = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
578 bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
579 | id `is_elem` local_ids
580 = lookupInst inst `thenTc` \ (dict_insts, (id,rhs)) ->
581 returnTc (listToBag dict_insts `plusLIE` insts,
582 VarMonoBind id rhs `AndMonoBinds` binds)
584 bind_inst some_other_inst (insts, binds)
585 -- Either not a method, or a method instance for an id not in local_ids
586 = returnTc (some_other_inst `consBag` insts, binds)
588 is_elem = isIn "bindInstsOfLocalFuns"
592 %************************************************************************
594 \section[Disambig]{Disambiguation of overloading}
596 %************************************************************************
599 If a dictionary constrains a type variable which is
602 not mentioned in the environment
604 and not mentioned in the type of the expression
606 then it is ambiguous. No further information will arise to instantiate
607 the type variable; nor will it be generalised and turned into an extra
608 parameter to a function.
610 It is an error for this to occur, except that Haskell provided for
611 certain rules to be applied in the special case of numeric types.
616 at least one of its classes is a numeric class, and
618 all of its classes are numeric or standard
620 then the type variable can be defaulted to the first type in the
621 default-type list which is an instance of all the offending classes.
623 So here is the function which does the work. It takes the ambiguous
624 dictionaries and either resolves them (producing bindings) or
625 complains. It works by splitting the dictionary list by type
626 variable, and using @disambigOne@ to do the real business.
628 IMPORTANT: @disambiguate@ assumes that its argument dictionaries
629 constrain only a simple type variable.
632 type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
634 disambiguateDicts :: LIE s -> TcM s ()
636 disambiguateDicts insts
637 = mapTc disambigOne inst_infos `thenTc` \ binds_lists ->
640 inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
641 (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
643 mk_inst_info dict@(Dict _ clas ty _ _)
644 = (dict, clas, getTyVar "disambiguateDicts" ty)
647 @disambigOne@ assumes that its arguments dictionaries constrain all
648 the same type variable.
650 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
651 @()@ instead of @Int@. I reckon this is the Right Thing to do since
652 the most common use of defaulting is code like:
654 _ccall_ foo `seqPrimIO` bar
656 Since we're not using the result of @foo@, the result if (presumably)
660 disambigOne :: [SimpleDictInfo s] -> TcM s ()
662 disambigOne dict_infos
663 | not (isStandardNumericDefaultable classes)
664 = failTc (ambigErr dicts) -- no default
666 | otherwise -- isStandardNumericDefaultable dict_infos
667 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
668 -- SO, TRY DEFAULT TYPES IN ORDER
670 -- Failure here is caused by there being no type in the
671 -- default list which can satisfy all the ambiguous classes.
672 -- For example, if Real a is reqd, but the only type in the
673 -- default list is Int.
674 tcGetDefaultTys `thenNF_Tc` \ default_tys ->
676 try_default [] -- No defaults work, so fail
677 = failTc (defaultErr dicts default_tys)
679 try_default (default_ty : default_tys)
680 = tryTc (try_default default_tys) $ -- If default_ty fails, we try
681 -- default_tys instead
682 tcSimplifyCheckThetas thetas `thenTc` \ _ ->
685 thetas = classes `zip` repeat default_ty
687 -- See if any default works, and if so bind the type variable to it
688 try_default default_tys `thenTc` \ chosen_default_ty ->
689 tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
690 unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
693 (_,_,tyvar) = head dict_infos -- Should be non-empty
694 dicts = [dict | (dict,_,_) <- dict_infos]
695 classes = [clas | (_,clas,_) <- dict_infos]
699 @isStandardNumericDefaultable@ sees whether the dicts have the
700 property required for defaulting; namely at least one is numeric, and
701 all are standard; or all are CcallIsh.
704 isStandardNumericDefaultable :: [Class] -> Bool
706 isStandardNumericDefaultable classes
707 = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $
708 (any isNumericClass classes && all isStandardClass classes)
709 || (all isCcallishClass 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 = ppAboves (map (pprInst sty "Ambiguous overloading") insts)
731 @reduceErr@ complains if we can't express required dictionaries in
732 terms of the signature.
736 = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature")
741 defaultErr dicts defaulting_tys sty
742 = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
744 ppHang (ppStr "Conflicting:")
745 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)),
746 ppHang (ppStr "Defaulting types :")
747 4 (ppr sty defaulting_tys),
748 ppStr "([Int, Double] is the default list of defaulting types.)" ])