TcSimplify.lhs 25 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
4
5
6
7
8
9
%
\section[TcSimplify]{TcSimplify}

\begin{code}
#include "HsVersions.h"

module TcSimplify (
10
	tcSimplify, tcSimplifyAndCheck,
11
12
13
14
	tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
	bindInstsOfLocalFuns
    ) where

15
IMP_Ubiq()
16
17

import HsSyn		( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, 
18
19
			  Match, HsBinds, HsType, ArithSeqInfo, Fixity,
			  GRHSsAndBinds, Stmt, DoOrListComp, Fake )
sof's avatar
sof committed
20
import HsBinds		( andMonoBinds )
sof's avatar
sof committed
21
import TcHsSyn		( SYN_IE(TcExpr), SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )
22

23
import TcMonad
24
import Inst		( lookupInst, lookupSimpleInst,
25
26
27
28
			  tyVarsOfInst, isTyVarDict, isDict,
			  matchesInst, instToId, instBindingRequired,
			  instCanBeGeneralised, newDictsAtLoc,
			  pprInst,
sof's avatar
sof committed
29
			  Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, pprLIE, pprLIEInFull,
30
31
			  plusLIE, unitLIE, consLIE, InstOrigin(..),
			  OverloadedLit )
32
import TcEnv		( tcGetGlobalTyVars )
33
import SpecEnv		( SpecEnv )
sof's avatar
sof committed
34
35
36
import TcType		( TcIdOcc(..), SYN_IE(TcIdBndr), 
			  SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType
			)
37
38
39
40
import Unify		( unifyTauTy )

import Bag		( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, 
			  snocBag, consBag, unionBags, isEmptyBag )
41
import Class		( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
42
			  isSuperClassOf, classSuperDictSelId, classInstEnv
43
			)
44
import Id		( GenId )
45
46
import PrelInfo		( isNumericClass, isStandardClass, isCcallishClass )

47
import Maybes		( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
sof's avatar
sof committed
48
import Outputable	( PprStyle, Outputable(..){-instance * []-} )
49
import PprType		( GenType, GenTyVar )
50
import Pretty
51
import SrcLoc		( noSrcLoc )
52
import Type		( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
53
			  getTyVar_maybe )
54
import TysWiredIn	( intTy, unitTy )
55
import TyVar		( GenTyVar, SYN_IE(GenTyVarSet), 
56
57
58
			  elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
			  isEmptyTyVarSet, tyVarSetToList )
import Unique		( Unique )
59
import Util
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
\end{code}


%************************************************************************
%*									*
\subsection[tcSimplify-main]{Main entry function}
%*									*
%************************************************************************

* May modify the substitution to bind ambiguous type variables.

Specification
~~~~~~~~~~~~~
(1) If an inst constrains only ``global'' type variables, (or none),
    return it as a ``global'' inst.

OTHERWISE

(2) Simplify it repeatedly (checking for (1) of course) until it is a dict
    constraining only a type variable.

(3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
    Otherwise it must be ambiguous, so try to resolve the ambiguity.


\begin{code}
86
87
88
89
90
91
92
tcSimpl :: Bool				-- True <=> simplify const insts
	-> TcTyVarSet s			-- ``Global'' type variables
	-> TcTyVarSet s			-- ``Local''  type variables
					-- ASSERT: both these tyvar sets are already zonked
	-> LIE s			-- Given; these constrain only local tyvars
	-> LIE s			-- Wanted
	-> TcM s (LIE s,			-- Free
sof's avatar
sof committed
93
		  TcMonoBinds s,		-- Bindings
94
95
96
97
98
99
100
101
		  LIE s)			-- Remaining wanteds; no dups

tcSimpl squash_consts global_tvs local_tvs givens wanteds
  =	-- ASSSERT: global_tvs and local_tvs are already zonked
	-- Make sure the insts fixed points of the substitution
    zonkLIE givens		 	`thenNF_Tc` \ givens ->
    zonkLIE wanteds		 	`thenNF_Tc` \ wanteds ->

102
103
	-- Deal with duplicates and type constructors
    elimTyCons
104
	 squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
105
106
	 givens wanteds		`thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->

107
   	-- Now disambiguate if necessary
108
    let
109
	ambigs = filterBag is_ambiguous locals_and_ambigs
110
    in
111
    if not (isEmptyBag ambigs) then
112
113
114
115
116
117
118
119
120
121
122
	-- Some ambiguous dictionaries.	 We now disambiguate them,
	-- which binds the offending type variables to suitable types in the
	-- substitution, and then we retry the whole process.  This
	-- time there won't be any ambiguous ones.
	-- There's no need to back-substitute on global and local tvs,
	-- because the ambiguous type variables can't be in either.

	-- Why do we retry the whole process?  Because binding a type variable
	-- to a particular type might enable a short-cut simplification which
	-- elimTyCons will have missed the first time.

123
124
125
126
127
128
129
130
131
132
133
134
135
136
	disambiguateDicts ambigs		`thenTc_`
	tcSimpl squash_consts global_tvs local_tvs givens wanteds

    else
	-- No ambiguous dictionaries.  Just bash on with the results
	-- of the elimTyCons

	-- Check for non-generalisable insts
    let
  	locals		= locals_and_ambigs	-- ambigs is empty
	cant_generalise = filterBag (not . instCanBeGeneralised) locals
    in
    checkTc (isEmptyBag cant_generalise)
	    (genCantGenErr cant_generalise)	`thenTc_`
137
138
139
140
141
142


	-- Deal with superclass relationships
    elimSCs givens locals		`thenNF_Tc` \ (sc_binds, locals2) ->

	 -- Finished
sof's avatar
sof committed
143
    returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2)
144
  where
145
146
    is_ambiguous (Dict _ _ ty _ _)
	= not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
147
148
149
150
151
152
153
154
155
156
157
\end{code}

The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
the ``don't-squash-consts'' flag set depending on top-level ness.  For
top level defns we *do* squash constants, so that they stay local to a
single defn.  This makes things which are inlined more likely to be
exportable, because their constants are "inside".  Later passes will
float them out if poss, after inlinings are sorted out.

\begin{code}
tcSimplify
158
159
160
	:: TcTyVarSet s			-- ``Local''  type variables
	-> LIE s			-- Wanted
	-> TcM s (LIE s,			-- Free
sof's avatar
sof committed
161
		  TcDictBinds s,		-- Bindings
162
163
164
165
166
167
168
169
170
171
		  LIE s)			-- Remaining wanteds; no dups

tcSimplify local_tvs wanteds
  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
    tcSimpl False global_tvs local_tvs emptyBag wanteds
\end{code}

@tcSimplifyAndCheck@ is similar to the above, except that it checks
that there is an empty wanted-set at the end.  It may still return
some of constant insts, which have to be resolved finally at the end.
172
173
174

\begin{code}
tcSimplifyAndCheck
175
176
177
	 :: TcTyVarSet s		-- ``Local''  type variables; ASSERT is fixpoint
	 -> LIE s			-- Given
	 -> LIE s			-- Wanted
sof's avatar
sof committed
178
179
	 -> TcM s (LIE s,		-- Free
		   TcDictBinds s)	-- Bindings
180
181
182
183
184
185
186

tcSimplifyAndCheck local_tvs givens wanteds
  = tcGetGlobalTyVars			`thenNF_Tc` \ global_tvs ->
    tcSimpl False global_tvs local_tvs
	    givens wanteds		`thenTc` \ (free_insts, binds, wanteds') ->
    checkTc (isEmptyBag wanteds')
	    (reduceErr wanteds')	`thenTc_`
187
188
189
190
    returnTc (free_insts, binds)
\end{code}

@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
191
is not overloaded.
192
193

\begin{code}
194
195
196
tcSimplifyRank2 :: TcTyVarSet s		-- ``Local'' type variables; ASSERT is fixpoint
		-> LIE s		-- Given
		-> TcM s (LIE s,			-- Free
sof's avatar
sof committed
197
			  TcDictBinds s)	-- Bindings
198
199
200
201
202
203


tcSimplifyRank2 local_tvs givens
  = zonkLIE givens			`thenNF_Tc` \ givens' ->
    elimTyCons True
	       (\tv -> not (tv `elementOfTyVarSet` local_tvs))
204
205
206
207
		-- This predicate claims that all
		-- any non-local tyvars are global,
		-- thereby postponing dealing with
		-- ambiguity until the enclosing Gen
208
	       emptyLIE givens'	`thenTc` \ (free, dict_binds, wanteds) ->
209

210
    checkTc (isEmptyBag wanteds) (reduceErr wanteds)	`thenTc_`
211

sof's avatar
sof committed
212
    returnTc (free, dict_binds)
213
214
215
216
217
218
\end{code}

@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
mechansim with the extra flag to say ``beat out constant insts''.

\begin{code}
sof's avatar
sof committed
219
tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
220
tcSimplifyTop dicts
221
  = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts	`thenTc` \ (_, binds, _) ->
222
223
224
225
226
227
228
229
230
231
    returnTc binds
\end{code}

%************************************************************************
%*									*
\subsection[elimTyCons]{@elimTyCons@}
%*									*
%************************************************************************

\begin{code}
232
233
234
235
236
elimTyCons :: Bool				-- True <=> Simplify const insts
	   -> (TcTyVar s -> Bool)		-- Free tyvar predicate
	   -> LIE s				-- Given
	   -> LIE s				-- Wanted
	   -> TcM s (LIE s,			-- Free
sof's avatar
sof committed
237
		     TcDictBinds s,		-- Bindings
238
		     LIE s			-- Remaining wanteds; no dups;
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
						-- dicts only (no Methods)
	       )
\end{code}

The bindings returned may mention any or all of ``givens'', so the
order in which the generated binds are put together is {\em tricky}.
Case~4 of @try@ is the general case to see.

When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...

    (1) first look up @wanted@; this gives us one binding to heave in:
	    wanted = rhs

    (2) step (1) also gave us some @simpler_wanteds@; we simplify
	these and get some (simpler-wanted-)bindings {\em that must be
	in scope} for the @wanted=rhs@ binding above!

    (3) we simplify the remaining @wanteds@ (recursive call), giving
	us yet more bindings.

The final arrangement of the {\em non-recursive} bindings is

    let <simpler-wanted-binds> in
    let wanted = rhs	       in
    let <yet-more-bindings> ...

\begin{code}
266
267
268
elimTyCons squash_consts is_free_tv givens wanteds
  = eTC givens (bagToList wanteds)	`thenTc` \ (_, free, binds, irreds) ->
    returnTc (free,binds,irreds)
269
  where
270
--    eTC :: LIE s -> [Inst s]
sof's avatar
sof committed
271
--	  -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s)
272

sof's avatar
sof committed
273
    eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag)
274

275
276
277
278
279
    eTC givens (wanted:wanteds)
    -- Case 0: same as an existing inst
      | maybeToBool maybe_equiv
      = eTC givens wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
	let
280
	  -- Create a new binding iff it's needed
281
	  this = expectJust "eTC" maybe_equiv
sof's avatar
sof committed
282
283
	  new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this)))
						   `AndMonoBinds` binds
284
285
286
		    | otherwise			 = binds
	in
	returnTc (givens1, frees, new_binds, irreds)
287
288
289
290
291
292

    -- Case 1: constrains no type variables at all
    -- In this case we have a quick go to see if it has an
    -- instance which requires no inputs (ie a constant); if so we use
    -- it; if not, we give up on the instance and just heave it out the
    -- top in the free result
293
294
295
      | isEmptyTyVarSet tvs_of_wanted
      = simplify_it squash_consts	{- If squash_consts is false,
					   simplify only if trival -}
296
297
298
		    givens wanted wanteds

    -- Case 2: constrains free vars only, so fling it out the top in free_ids
299
300
301
      | all is_free_tv (tyVarSetToList tvs_of_wanted)
      = eTC (wanted `consBag` givens) wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
	returnTc (givens1, wanted `consBag` frees, binds, irreds)
302
303
304
305

    -- Case 3: is a dict constraining only a tyvar,
    -- so return it as part of the "wanteds" result
      | isTyVarDict wanted
306
307
      = eTC (wanted `consBag` givens) wanteds	`thenTc` \ (givens1, frees, binds, irreds) ->
	returnTc (givens1, frees, binds, wanted `consBag` irreds)
308
309

    -- Case 4: is not a simple dict, so look up in instance environment
310
311
      | otherwise
      = simplify_it True {- Simplify even if not trivial -}
312
		    givens wanted wanteds
313
314
315
316
317
318
319
320
321
322
323
324
      where
	tvs_of_wanted  = tyVarsOfInst wanted

	-- Look for something in "givens" that matches "wanted"
	Just the_equiv = maybe_equiv
	maybe_equiv    = foldBag seqMaybe try Nothing givens
	try given | wanted `matchesInst` given = Just given
		  | otherwise		       = Nothing


    simplify_it simplify_always givens wanted wanteds
	-- Recover immediately on no-such-instance errors
sof's avatar
sof committed
325
      = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE)) 
326
327
328
329
		  (simplify_one simplify_always givens wanted)
				`thenTc` \ (givens1, frees1, binds1, irreds1) ->
	eTC givens1 wanteds	`thenTc` \ (givens2, frees2, binds2, irreds2) ->
	returnTc (givens2, frees1 `plusLIE` frees2,
sof's avatar
sof committed
330
			   binds1 `AndMonoBinds` binds2,
331
332
333
334
335
336
337
338
339
340
341
342
		  	   irreds1 `plusLIE` irreds2)


    simplify_one simplify_always givens wanted
     | not (instBindingRequired wanted)
     = 		-- No binding required for this chap, so squash right away
	   lookupInst wanted		`thenTc` \ (simpler_wanteds, _) ->
	   eTC givens simpler_wanteds	`thenTc` \ (givens1, frees1, binds1, irreds1) ->
	   returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)

     | otherwise
     = 		-- An binding is required for this inst
sof's avatar
sof committed
343
	lookupInst wanted		`thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) ->
344
345

	if (not_var rhs && not simplify_always) then
346
	   -- Ho ho!  It isn't trivial to simplify "wanted",
347
348
	   -- because the rhs isn't a simple variable.	Unless the flag
	   -- simplify_always is set, just give up now and
349
	   -- just fling it out the top.
sof's avatar
sof committed
350
	   returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE)
351
	else
352
353
354
355
	   -- Aha! Either it's easy, or simplify_always is True
	   -- so we must do it right here.
	   eTC givens simpler_wanteds	`thenTc` \ (givens1, frees1, binds1, irreds1) ->
	   returnTc (wanted `consLIE` givens1, frees1,
sof's avatar
sof committed
356
		     binds1 `AndMonoBinds` bind,
357
358
359
360
361
		     irreds1)

    not_var :: TcExpr s -> Bool
    not_var (HsVar _) = False
    not_var other     = True
362
363
364
365
366
367
\end{code}


%************************************************************************
%*									*
\subsection[elimSCs]{@elimSCs@}
368
%*									*
369
370
371
%************************************************************************

\begin{code}
372
373
elimSCs :: LIE s				-- Given; no dups
	-> LIE s				-- Wanted; no dups; all dictionaries, all
374
						-- constraining just a type variable
sof's avatar
sof committed
375
	-> NF_TcM s (TcDictBinds s,		-- Bindings
376
		     LIE s)			-- Minimal wanted set
377
378
379
380

elimSCs givens wanteds
  = -- Sort the wanteds so that subclasses occur before superclasses
    elimSCs_help
381
	(filterBag isDict givens)	-- Filter out non-dictionaries
382
383
	(sortSC wanteds)

384
385
elimSCs_help :: LIE s					-- Given; no dups
	     -> [Inst s]				-- Wanted; no dups;
sof's avatar
sof committed
386
	     -> NF_TcM s (TcDictBinds s,		-- Bindings
387
		    	  LIE s)			-- Minimal wanted set
388

sof's avatar
sof committed
389
elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE)
390

391
392
393
elimSCs_help givens (wanted:wanteds)
  = trySC givens wanted 		`thenNF_Tc` \ (givens1, binds1, irreds1) ->
    elimSCs_help givens1 wanteds	`thenNF_Tc` \ (binds2, irreds2) ->
sof's avatar
sof committed
394
    returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2)
395
396


397
398
399
trySC :: LIE s				-- Givens
      -> Inst s				-- Wanted
      -> NF_TcM s (LIE s,			-- New givens,
sof's avatar
sof committed
400
		   TcDictBinds s,		-- Bindings
401
		   LIE s)			-- Irreducible wanted set
402

403
404
405
trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
  | not (maybeToBool maybe_best_subclass_chain)
  = 	-- No superclass relationship
sof's avatar
sof committed
406
    returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted)
407

408
409
410
411
412
413
414
415
  | otherwise
  = 	-- There's a subclass relationship with a "given"
	-- Build intermediate dictionaries
    let
	theta = [ (clas, wanted_ty) | clas <- reverse classes ]
	-- The reverse is because the list comes back in the "wrong" order I think
    in
    newDictsAtLoc wanted_orig loc theta		`thenNF_Tc` \ (intermediates, _) ->
416
417
418
419

	-- Create bindings for the wanted dictionary and the intermediates.
	-- Later binds may depend on earlier ones, so each new binding is pushed
	-- on the front of the accumulating parameter list of bindings
420
421
422
    let
	mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
	  = ((dict_sub, dict_sub_class),
sof's avatar
sof committed
423
424
	     (VarMonoBind (instToId dict)
			  (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class 
425
426
									      clas)))
					    [ty])
sof's avatar
sof committed
427
				     [instToId dict_sub])))
428
429
430
	(_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
    in
    returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
sof's avatar
sof committed
431
	         andMonoBinds new_binds,
432
433
	         emptyLIE)

434
  where
435
436
    maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
    Just (given, classes, _) = maybe_best_subclass_chain
437

438
439
440
441
    choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2  = c1
						      | otherwise = c2
    choose_best Nothing		   c2				  = c2
    choose_best c1		   Nothing		  	  = c1
442

443
444
    find_subclass_chain given@(Dict _ given_class given_ty _ _)
	 | wanted_ty `eqSimpleTy` given_ty
445
446
447
448
449
450
451
452
453
454
455
	 = case (wanted_class `isSuperClassOf` given_class) of

		 Just classes -> Just (given,
				       classes,
				       length classes)

		 Nothing      -> Nothing

	 | otherwise = Nothing


456
sortSC :: LIE s     -- Expected to be all dicts (no MethodIds), all of
457
		    -- which constrain type variables
458
       -> [Inst s]  -- Sorted with subclasses before superclasses
459

460
sortSC dicts = sortLt lt (bagToList dicts)
461
  where
462
    (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
463
464
465
       = maybeToBool (c2 `isSuperClassOf` c1)
	-- The ice is a bit thin here because this "lt" isn't a total order
	-- But it *is* transitive, so it works ok
466
467
468
\end{code}


469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
%************************************************************************
%*									*
\subsection[simple]{@Simple@ versions}
%*									*
%************************************************************************

Much simpler versions when there are no bindings to make!

@tcSimplifyThetas@ simplifies class-type constraints formed by
@deriving@ declarations and when specialising instances.  We are
only interested in the simplified bunch of class/type constraints.

\begin{code}
tcSimplifyThetas :: (Class -> ClassInstEnv)		-- How to find the ClassInstEnv
	       	 -> [(Class, TauType)]			-- Given
	       	 -> [(Class, TauType)]			-- Wanted
	       	 -> TcM s [(Class, TauType)]


tcSimplifyThetas inst_mapper given wanted
  = elimTyConsSimple inst_mapper wanted	`thenTc`    \ wanted1 ->
    returnTc (elimSCsSimple given wanted1)
\end{code}

@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
used with \tr{default} declarations.  We are only interested in
whether it worked or not.

\begin{code}
tcSimplifyCheckThetas :: [(Class, TauType)]	-- Simplify this to nothing at all
		      -> TcM s ()

tcSimplifyCheckThetas theta
  = elimTyConsSimple classInstEnv theta    `thenTc`	\ theta1 ->
    ASSERT( null theta1 )
    returnTc ()
\end{code}


\begin{code}
elimTyConsSimple :: (Class -> ClassInstEnv) 
	         -> [(Class,Type)]
	         -> TcM s [(Class,Type)]
elimTyConsSimple inst_mapper theta
  = elim theta
  where
    elim []	          = returnTc []
    elim ((clas,ty):rest) = elim_one clas ty 	`thenTc` \ r1 ->
			    elim rest		`thenTc` \ r2 ->
			    returnTc (r1++r2)

    elim_one clas ty
	= case getTyVar_maybe ty of

	    Just tv   -> returnTc [(clas,ty)]

	    otherwise -> recoverTc (returnTc []) $
			 lookupSimpleInst (inst_mapper clas) clas ty	`thenTc` \ theta ->
			 elim theta

elimSCsSimple :: [(Class,Type)] 	-- Given
	      -> [(Class,Type)]		-- Wanted
	      -> [(Class,Type)]		-- Subset of wanted; no dups, no subclass relnships

elimSCsSimple givens [] = []
elimSCsSimple givens (c_t@(clas,ty) : rest)
  | any (`subsumes` c_t) givens ||
    any (`subsumes` c_t) rest				-- (clas,ty) is old hat
  = elimSCsSimple givens rest
  | otherwise						-- (clas,ty) is new
  = c_t : elimSCsSimple (c_t : givens) rest
  where
    rest' = elimSCsSimple rest
    (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && 
543
544
545
546
				 (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
-- We deal with duplicates here   ^^^^^^^^
-- It's a simple place to do it, although it's done in elimTyCons in the
-- full-blown version of the simpifier.
547
548
\end{code}

549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
%************************************************************************
%*									*
\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
%*									*
%************************************************************************

When doing a binding group, we may have @Insts@ of local functions.
For example, we might have...
\begin{verbatim}
let f x = x + 1	    -- orig local function (overloaded)
    f.1 = f Int	    -- two instances of f
    f.2 = f Float
 in
    (f.1 5, f.2 6.7)
\end{verbatim}
The point is: we must drop the bindings for @f.1@ and @f.2@ here,
where @f@ is in scope; those @Insts@ must certainly not be passed
upwards towards the top-level.	If the @Insts@ were binding-ified up
there, they would have unresolvable references to @f@.

We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
For each method @Inst@ in the @init_lie@ that mentions one of the
@Ids@, we create a binding.  We return the remaining @Insts@ (in an
572
@LIE@), as well as the @HsBinds@ generated.
573
574

\begin{code}
575
bindInstsOfLocalFuns ::	LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
576
577

bindInstsOfLocalFuns init_lie local_ids
578
  = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
579
  where
580
    bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
581
      | id `is_elem` local_ids
sof's avatar
sof committed
582
      = lookupInst inst		`thenTc` \ (dict_insts, bind) ->
583
	returnTc (listToBag dict_insts `plusLIE` insts, 
sof's avatar
sof committed
584
		  bind `AndMonoBinds` binds)
585

586
    bind_inst some_other_inst (insts, binds)
587
	-- Either not a method, or a method instance for an id not in local_ids
588
      = returnTc (some_other_inst `consBag` insts, binds)
589
590
591

    is_elem = isIn "bindInstsOfLocalFuns"
\end{code}
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664


%************************************************************************
%*									*
\section[Disambig]{Disambiguation of overloading}
%*									*
%************************************************************************


If a dictionary constrains a type variable which is
\begin{itemize}
\item
not mentioned in the environment
\item
and not mentioned in the type of the expression
\end{itemize}
then it is ambiguous. No further information will arise to instantiate
the type variable; nor will it be generalised and turned into an extra
parameter to a function.

It is an error for this to occur, except that Haskell provided for
certain rules to be applied in the special case of numeric types.

Specifically, if
\begin{itemize}
\item
at least one of its classes is a numeric class, and
\item
all of its classes are numeric or standard
\end{itemize}
then the type variable can be defaulted to the first type in the
default-type list which is an instance of all the offending classes.

So here is the function which does the work.  It takes the ambiguous
dictionaries and either resolves them (producing bindings) or
complains.  It works by splitting the dictionary list by type
variable, and using @disambigOne@ to do the real business.

IMPORTANT: @disambiguate@ assumes that its argument dictionaries
constrain only a simple type variable.

\begin{code}
type SimpleDictInfo s = (Inst s, Class, TcTyVar s)

disambiguateDicts :: LIE s -> TcM s ()

disambiguateDicts insts
  = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
    returnTc ()
  where
    inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
    (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2

    mk_inst_info dict@(Dict _ clas ty _ _)
      = (dict, clas, getTyVar "disambiguateDicts" ty)
\end{code}

@disambigOne@ assumes that its arguments dictionaries constrain all
the same type variable.

ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
@()@ instead of @Int@.  I reckon this is the Right Thing to do since
the most common use of defaulting is code like:
\begin{verbatim}
	_ccall_ foo	`seqPrimIO` bar
\end{verbatim}
Since we're not using the result of @foo@, the result if (presumably)
@void@.

\begin{code}
disambigOne :: [SimpleDictInfo s] -> TcM s ()

disambigOne dict_infos
665
  |  any isNumericClass classes && all isStandardClass classes
666
667
668
669
670
671
672
673
674
675
  = 	-- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
	-- SO, TRY DEFAULT TYPES IN ORDER

	-- Failure here is caused by there being no type in the
	-- default list which can satisfy all the ambiguous classes.
	-- For example, if Real a is reqd, but the only type in the
	-- default list is Int.
    tcGetDefaultTys			`thenNF_Tc` \ default_tys ->
    let
      try_default [] 	-- No defaults work, so fail
676
	= failTc (ambigErr dicts) 
677
678
679
680

      try_default (default_ty : default_tys)
	= tryTc (try_default default_tys) $	-- If default_ty fails, we try
						-- default_tys instead
681
	  tcSimplifyCheckThetas thetas	`thenTc` \ _ ->
682
683
684
685
686
687
688
	  returnTc default_ty
        where
	  thetas = classes `zip` repeat default_ty
    in
	-- See if any default works, and if so bind the type variable to it
    try_default default_tys		`thenTc` \ chosen_default_ty ->
    tcInstType [] chosen_default_ty	`thenNF_Tc` \ chosen_default_tc_ty ->	-- Tiresome!
689
    unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
690

691
692
693
694
695
696
697
698
  | all isCcallishClass classes
  = 	-- Default CCall stuff to (); we don't even both to check that () is an 
	-- instance of CCallable/CReturnable, because we know it is.
    unifyTauTy (mkTyVarTy tyvar) unitTy    
    
  | otherwise -- No defaults
  = failTc (ambigErr dicts)

699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
  where
    (_,_,tyvar) = head dict_infos		-- Should be non-empty
    dicts   = [dict | (dict,_,_) <- dict_infos]
    classes = [clas | (_,clas,_) <- dict_infos]

\end{code}



Errors and contexts
~~~~~~~~~~~~~~~~~~~
ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?

\begin{code}
genCantGenErr insts sty	-- Can't generalise these Insts
sof's avatar
sof committed
716
717
  = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):")) 
	   4  (vcat (map (ppr sty) (bagToList insts)))
718
719
720
\end{code}

\begin{code}
sof's avatar
sof committed
721
722
723
724
725
726
ambigErr dicts sty
  = sep [text "Ambiguous context" <+> pprLIE sty lie,
	 nest 4 (pprLIEInFull sty lie)
    ]
  where
    lie = listToBag dicts	-- Yuk
727
728
729
730
731
732
\end{code}

@reduceErr@ complains if we can't express required dictionaries in
terms of the signature.

\begin{code}
sof's avatar
sof committed
733
734
735
736
737
reduceErr lie sty
  = sep [text "Context" <+> pprLIE sty lie,
	 nest 4 (text "required by inferred type, but missing on a type signature"),
	 nest 4 (pprLIEInFull sty lie)
    ]
738
739
740
\end{code}