TcSimplify.lhs 72.6 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
%
\section[TcSimplify]{TcSimplify}

6
7
8


\begin{code}
9
module TcSimplify (
10
	tcSimplifyInfer, tcSimplifyInferCheck,
11
	tcSimplifyCheck, tcSimplifyRestricted,
12
13
	tcSimplifyToDicts, tcSimplifyIPs, 
	tcSimplifyTop, tcSimplifyInteractive,
14
	tcSimplifyBracket,
15

16
	tcSimplifyDeriv, tcSimplifyDefault,
17
	bindInstsOfLocalFuns
18
19
    ) where

20
#include "HsVersions.h"
21

22
import {-# SOURCE #-} TcUnify( unifyTauTy )
23
import TcEnv		-- temp
24
import HsSyn		( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
25
import TcHsSyn		( TcExpr, TcId,
26
27
			  TcMonoBinds, TcDictBinds
			)
28

29
import TcRnMonad
30
import Inst		( lookupInst, LookupInstResult(..),
31
			  tyVarsOfInst, fdPredsOfInsts, fdPredsOfInst, newDicts,
32
33
34
			  isDict, isClassDict, isLinearInst, linearInstType,
			  isStdClassTyVarDict, isMethodFor, isMethod,
			  instToId, tyVarsOfInsts,  cloneDict,
35
			  ipNamesOfInsts, ipNamesOfInst, dictPred,
36
			  instBindingRequired,
37
			  newDictsFromOld, tcInstClassOp,
38
			  getDictClassTys, isTyVarDict,
39
			  instLoc, zonkInst, tidyInsts, tidyMoreInsts,
40
41
			  Inst, pprInsts, pprInstsInFull, tcGetInstEnvs,
			  isIPDict, isInheritableInst, pprDFuns
sof's avatar
sof committed
42
			)
43
44
import TcEnv		( tcGetGlobalTyVars, tcLookupId, findGlobals )
import InstEnv		( lookupInstEnv, classInstEnv )
45
import TcMType		( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
46
import TcType		( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
47
			  mkClassPred, isOverloadedTy, mkTyConApp,
48
			  mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
49
			  tyVarsOfPred )
50
import Id		( idType, mkUserLocal )
51
import Var		( TyVar )
52
import Name		( getOccName, getSrcLoc )
53
import NameSet		( NameSet, mkNameSet, elemNameSet )
54
import Class		( classBigSig, classKey )
55
import FunDeps		( oclose, grow, improve, pprEquationDoc )
56
import PrelInfo		( isNumericClass ) 
57
58
import PrelNames	( splitName, fstName, sndName, integerTyConName,
			  showClassKey, eqClassKey, ordClassKey )
59
import Subst		( mkTopTyVarSubst, substTheta, substTy )
60
import TysWiredIn	( pairTyCon, doubleTy )
61
import ErrUtils		( Message )
62
import VarSet
63
import VarEnv		( TidyEnv )
64
65
import FiniteMap
import Outputable
66
import ListSetOps	( equivClasses )
67
import Util		( zipEqual, isSingleton )
68
import List		( partition )
69
import CmdLineOpts
70
71
72
73
74
\end{code}


%************************************************************************
%*									*
75
\subsection{NOTES}
76
77
78
%*									*
%************************************************************************

79
	--------------------------------------
80
		Notes on quantification
81
	--------------------------------------
82
83
84
85
86
87

Suppose we are about to do a generalisation step.
We have in our hand

	G	the environment
	T	the type of the RHS
88
	C	the constraints from that RHS
89
90
91
92
93
94
95
96
97
98
99

The game is to figure out

	Q	the set of type variables over which to quantify
	Ct	the constraints we will *not* quantify over
	Cq	the constraints we will quantify over

So we're going to infer the type

	forall Q. Cq => T

100
and float the constraints Ct further outwards.
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138

Here are the things that *must* be true:

 (A)	Q intersect fv(G) = EMPTY			limits how big Q can be
 (B)	Q superset fv(Cq union T) \ oclose(fv(G),C)	limits how small Q can be

(A) says we can't quantify over a variable that's free in the
environment.  (B) says we must quantify over all the truly free
variables in T, else we won't get a sufficiently general type.  We do
not *need* to quantify over any variable that is fixed by the free
vars of the environment G.

	BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!

Example:	class H x y | x->y where ...

	fv(G) = {a}	C = {H a b, H c d}
			T = c -> b

	(A)  Q intersect {a} is empty
	(B)  Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}

	So Q can be {c,d}, {b,c,d}

Other things being equal, however, we'd like to quantify over as few
variables as possible: smaller types, fewer type applications, more
constraints can get into Ct instead of Cq.


-----------------------------------------
We will make use of

  fv(T)	 	the free type vars of T

  oclose(vs,C)	The result of extending the set of tyvars vs
		using the functional dependencies from C

  grow(vs,C)	The result of extend the set of tyvars vs
139
		using all conceivable links from C.
140
141
142
143
144
145
146

		E.g. vs = {a}, C = {H [a] b, K (b,Int) c, Eq e}
		Then grow(vs,C) = {a,b,c}

		Note that grow(vs,C) `superset` grow(vs,simplify(C))
		That is, simplfication can only shrink the result of grow.

147
Notice that
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
   oclose is conservative one way:      v `elem` oclose(vs,C) => v is definitely fixed by vs
   grow is conservative the other way:  if v might be fixed by vs => v `elem` grow(vs,C)


-----------------------------------------

Choosing Q
~~~~~~~~~~
Here's a good way to choose Q:

	Q = grow( fv(T), C ) \ oclose( fv(G), C )

That is, quantify over all variable that that MIGHT be fixed by the
call site (which influences T), but which aren't DEFINITELY fixed by
G.  This choice definitely quantifies over enough type variables,
albeit perhaps too many.

Why grow( fv(T), C ) rather than fv(T)?  Consider

	class H x y | x->y where ...
168

169
170
171
172
173
174
175
	T = c->c
	C = (H c d)

  If we used fv(T) = {c} we'd get the type

	forall c. H c d => c -> b

176
  And then if the fn was called at several different c's, each of
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
  which fixed d differently, we'd get a unification error, because
  d isn't quantified.  Solution: quantify d.  So we must quantify
  everything that might be influenced by c.

Why not oclose( fv(T), C )?  Because we might not be able to see
all the functional dependencies yet:

	class H x y | x->y where ...
	instance H x y => Eq (T x y) where ...

	T = c->c
	C = (Eq (T c d))

  Now oclose(fv(T),C) = {c}, because the functional dependency isn't
  apparent yet, and that's wrong.  We must really quantify over d too.


There really isn't any point in quantifying over any more than
grow( fv(T), C ), because the call sites can't possibly influence
any other type variables.



200
201
202
	--------------------------------------
		Notes on ambiguity
	--------------------------------------
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

It's very hard to be certain when a type is ambiguous.  Consider

	class K x
	class H x y | x -> y
	instance H x y => K (x,y)

Is this type ambiguous?
	forall a b. (K (a,b), Eq b) => a -> a

Looks like it!  But if we simplify (K (a,b)) we get (H a b) and
now we see that a fixes b.  So we can't tell about ambiguity for sure
without doing a full simplification.  And even that isn't possible if
the context has some free vars that may get unified.  Urgle!

Here's another example: is this ambiguous?
	forall a b. Eq (T b) => a -> a
Not if there's an insance decl (with no context)
	instance Eq (T b) where ...

You may say of this example that we should use the instance decl right
away, but you can't always do that:

	class J a b where ...
	instance J Int b where ...

	f :: forall a b. J a b => a -> a

(Notice: no functional dependency in J's class decl.)
Here f's type is perfectly fine, provided f is only called at Int.
It's premature to complain when meeting f's signature, or even
when inferring a type for f.



However, we don't *need* to report ambiguity right away.  It'll always
show up at the call site.... and eventually at main, which needs special
treatment.  Nevertheless, reporting ambiguity promptly is an excellent thing.

242
So here's the plan.  We WARN about probable ambiguity if
243
244
245
246
247

	fv(Cq) is not a subset of  oclose(fv(T) union fv(G), C)

(all tested before quantification).
That is, all the type variables in Cq must be fixed by the the variables
248
in the environment, or by the variables in the type.
249
250
251

Notice that we union before calling oclose.  Here's an example:

252
	class J a b c | a b -> c
253
254
255
	fv(G) = {a}

Is this ambiguous?
256
	forall b c. (J a b c) => b -> b
257
258

Only if we union {a} from G with {b} from T before using oclose,
259
do we see that c is fixed.
260

261
It's a bit vague exactly which C we should use for this oclose call.  If we
262
263
264
265
266
267
268
269
270
don't fix enough variables we might complain when we shouldn't (see
the above nasty example).  Nothing will be perfect.  That's why we can
only issue a warning.


Can we ever be *certain* about ambiguity?  Yes: if there's a constraint

	c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY

271
then c is a "bubble"; there's no way it can ever improve, and it's
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
certainly ambiguous.  UNLESS it is a constant (sigh).  And what about
the nasty example?

	class K x
	class H x y | x -> y
	instance H x y => K (x,y)

Is this type ambiguous?
	forall a b. (K (a,b), Eq b) => a -> a

Urk.  The (Eq b) looks "definitely ambiguous" but it isn't.  What we are after
is a "bubble" that's a set of constraints

	Cq = Ca union Cq'  st  fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY

Hence another idea.  To decide Q start with fv(T) and grow it
by transitive closure in Cq (no functional dependencies involved).
Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
290
The definitely-ambiguous can then float out, and get smashed at top level
291
292
293
(which squashes out the constants, like Eq (T a) above)


294
	--------------------------------------
295
		Notes on principal types
296
	--------------------------------------
297
298
299

    class C a where
      op :: a -> a
300

301
302
303
304
305
306
307
    f x = let g y = op (y::Int) in True

Here the principal type of f is (forall a. a->a)
but we'll produce the non-principal type
    f :: forall a. C Int => a -> a


308
	--------------------------------------
309
		Notes on implicit parameters
310
	--------------------------------------
311

312
313
314
315
316
Question 1: can we "inherit" implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:

	f x = (x::Int) + ?y
317

318
319
320
where f is *not* a top-level binding.
From the RHS of f we'll get the constraint (?y::Int).
There are two types we might infer for f:
321

322
323
324
	f :: Int -> Int

(so we get ?y from the context of f's definition), or
325
326
327

	f :: (?y::Int) => Int -> Int

328
329
330
331
332
333
At first you might think the first was better, becuase then
?y behaves like a free variable of the definition, rather than
having to be passed at each call site.  But of course, the WHOLE
IDEA is that ?y should be passed at each call site (that's what
dynamic binding means) so we'd better infer the second.

334
335
BOTTOM LINE: when *inferring types* you *must* quantify 
over implicit parameters. See the predicate isFreeWhenInferring.
336

337
338
339
340
341

Question 2: type signatures
~~~~~~~~~~~~~~~~~~~~~~~~~~~
BUT WATCH OUT: When you supply a type signature, we can't force you
to quantify over implicit parameters.  For example:
342
343
344
345
346
347
348
349
350
351
352

	(?x + 1) :: Int

This is perfectly reasonable.  We do not want to insist on

	(?x + 1) :: (?x::Int => Int)

That would be silly.  Here, the definition site *is* the occurrence site,
so the above strictures don't apply.  Hence the difference between
tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
and tcSimplifyCheckBind (which does not).
353

354
355
356
What about when you supply a type signature for a binding?
Is it legal to give the following explicit, user type 
signature to f, thus:
357

358
	f :: Int -> Int
359
	f x = (x::Int) + ?y
360

361
At first sight this seems reasonable, but it has the nasty property
362
that adding a type signature changes the dynamic semantics.
363
Consider this:
364

365
	(let f x = (x::Int) + ?y
366
367
368
369
 	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+5)
vs
370
	(let f :: Int -> Int
371
	     f x = x + ?y
372
373
374
375
	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+6)

376
377
Indeed, simply inlining f (at the Haskell source level) would change the
dynamic semantics.
378

379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
Nevertheless, as Launchbury says (email Oct 01) we can't really give the
semantics for a Haskell program without knowing its typing, so if you 
change the typing you may change the semantics.

To make things consistent in all cases where we are *checking* against
a supplied signature (as opposed to inferring a type), we adopt the
rule: 

	a signature does not need to quantify over implicit params.

[This represents a (rather marginal) change of policy since GHC 5.02,
which *required* an explicit signature to quantify over all implicit
params for the reasons mentioned above.]

But that raises a new question.  Consider 

	Given (signature)	?x::Int
	Wanted (inferred)	?x::Int, ?y::Bool

Clearly we want to discharge the ?x and float the ?y out.  But
what is the criterion that distinguishes them?  Clearly it isn't
what free type variables they have.  The Right Thing seems to be
to float a constraint that
	neither mentions any of the quantified type variables
	nor any of the quantified implicit parameters

See the predicate isFreeWhenChecking.
406

407

408
409
410
Question 3: monomorphism
~~~~~~~~~~~~~~~~~~~~~~~~
There's a nasty corner case when the monomorphism restriction bites:
411

412
413
	z = (x::Int) + ?y

414
415
The argument above suggests that we *must* generalise
over the ?y parameter, to get
416
417
	z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
418
	z :: Int.
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
Why does the momomorphism restriction say this?  Because if you have

	let z = x + ?y in z+z

you might not expect the addition to be done twice --- but it will if
we follow the argument of Question 2 and generalise over ?y.



Possible choices
~~~~~~~~~~~~~~~~
(A) Always generalise over implicit parameters
    Bindings that fall under the monomorphism restriction can't
	be generalised

    Consequences:
435
	* Inlining remains valid
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
	* No unexpected loss of sharing
	* But simple bindings like
		z = ?y + 1
	  will be rejected, unless you add an explicit type signature
	  (to avoid the monomorphism restriction)
		z :: (?y::Int) => Int
		z = ?y + 1
	  This seems unacceptable

(B) Monomorphism restriction "wins"
    Bindings that fall under the monomorphism restriction can't
	be generalised
    Always generalise over implicit parameters *except* for bindings
	that fall under the monomorphism restriction

    Consequences
	* Inlining isn't valid in general
	* No unexpected loss of sharing
	* Simple bindings like
		z = ?y + 1
	  accepted (get value of ?y from binding site)

(C) Always generalise over implicit parameters
    Bindings that fall under the monomorphism restriction can't
	be generalised, EXCEPT for implicit parameters
    Consequences
	* Inlining remains valid
	* Unexpected loss of sharing (from the extra generalisation)
	* Simple bindings like
		z = ?y + 1
	  accepted (get value of ?y from occurrence sites)


Discussion
~~~~~~~~~~
None of these choices seems very satisfactory.  But at least we should
decide which we want to do.
473

474
It's really not clear what is the Right Thing To Do.  If you see
475

476
	z = (x::Int) + ?y
477

478
479
480
481
482
483
would you expect the value of ?y to be got from the *occurrence sites*
of 'z', or from the valuue of ?y at the *definition* of 'z'?  In the
case of function definitions, the answer is clearly the former, but
less so in the case of non-fucntion definitions.   On the other hand,
if we say that we get the value of ?y from the definition site of 'z',
then inlining 'z' might change the semantics of the program.
484

485
Choice (C) really says "the monomorphism restriction doesn't apply
486
to implicit parameters".  Which is fine, but remember that every
487
488
489
innocent binding 'x = ...' that mentions an implicit parameter in
the RHS becomes a *function* of that parameter, called at each
use of 'x'.  Now, the chances are that there are no intervening 'with'
490
clauses that bind ?y, so a decent compiler should common up all
491
492
493
those function calls.  So I think I strongly favour (C).  Indeed,
one could make a similar argument for abolishing the monomorphism
restriction altogether.
494

495
BOTTOM LINE: we choose (B) at present.  See tcSimplifyRestricted
496

497

498

499
500
501
502
503
504
505
506
507
%************************************************************************
%*									*
\subsection{tcSimplifyInfer}
%*									*
%************************************************************************

tcSimplify is called when we *inferring* a type.  Here's the overall game plan:

    1. Compute Q = grow( fvs(T), C )
508
509

    2. Partition C based on Q into Ct and Cq.  Notice that ambiguous
510
       predicates will end up in Ct; we deal with them at the top level
511

512
    3. Try improvement, using functional dependencies
513

514
515
516
517
    4. If Step 3 did any unification, repeat from step 1
       (Unification can change the result of 'grow'.)

Note: we don't reduce dictionaries in step 2.  For example, if we have
518
Eq (a,b), we don't simplify to (Eq a, Eq b).  So Q won't be different
519
520
521
522
523
524
525
after step 2.  However note that we may therefore quantify over more
type variables than we absolutely have to.

For the guts, we need a loop, that alternates context reduction and
improvement with unification.  E.g. Suppose we have

	class C x y | x->y where ...
526

527
528
529
530
531
532
and tcSimplify is called with:
	(C Int a, C Int b)
Then improvement unifies a with b, giving
	(C Int a, C Int a)

If we need to unify anything, we rattle round the whole thing all over
533
again.
534

535
536

\begin{code}
537
tcSimplifyInfer
538
539
	:: SDoc
	-> TcTyVarSet		-- fv(T); type vars
540
	-> [Inst]		-- Wanted
541
542
543
	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked)
		TcDictBinds,	-- Bindings
		[TcId])		-- Dict Ids that must be bound here (zonked)
544
	-- Any free (escaping) Insts are tossed into the environment
545
\end{code}
546

547
548
549

\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
550
  = inferLoop doc (varSetElems tau_tvs)
551
	      wanted_lie		`thenM` \ (qtvs, frees, binds, irreds) ->
552

553
554
    extendLIEs frees							`thenM_`
    returnM (qtvs, binds, map instToId irreds)
555
556
557

inferLoop doc tau_tvs wanteds
  =   	-- Step 1
558
559
560
    zonkTcTyVarsAndFV tau_tvs		`thenM` \ tau_tvs' ->
    mappM zonkInst wanteds		`thenM` \ wanteds' ->
    tcGetGlobalTyVars			`thenM` \ gbl_tvs ->
561
    let
562
 	preds = fdPredsOfInsts wanteds'
563
	qtvs  = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
564
565

	try_me inst
566
567
568
	  | isFreeWhenInferring qtvs inst = Free
	  | isClassDict inst 		  = DontReduceUnlessConstant	-- Dicts
	  | otherwise	    		  = ReduceMe 			-- Lits and Methods
569
    in
570
    traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs])	`thenM_`
571
		-- Step 2
572
    reduceContext doc try_me [] wanteds'    `thenM` \ (no_improvement, frees, binds, irreds) ->
573

574
575
		-- Step 3
    if no_improvement then
576
	returnM (varSetElems qtvs, frees, binds, irreds)
577
    else
578
579
580
581
582
583
584
585
586
587
588
589
	-- If improvement did some unification, we go round again.  There
	-- are two subtleties:
	--   a) We start again with irreds, not wanteds
	-- 	Using an instance decl might have introduced a fresh type variable
	--	which might have been unified, so we'd get an infinite loop
	--	if we started again with wanteds!  See example [LOOP]
	--
	--   b) It's also essential to re-process frees, because unification
	--      might mean that a type variable that looked free isn't now.
	--
	-- Hence the (irreds ++ frees)

590
591
592
	-- However, NOTICE that when we are done, we might have some bindings, but
	-- the final qtvs might be empty.  See [NO TYVARS] below.
				
593
594
	inferLoop doc tau_tvs (irreds ++ frees)	`thenM` \ (qtvs1, frees1, binds1, irreds1) ->
	returnM (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
595
\end{code}
596

597
598
599
600
601
602
603
604
605
606
607
608
609
Example [LOOP]

	class If b t e r | b t e -> r
	instance If T t e t
	instance If F t e e
	class Lte a b c | a b -> c where lte :: a -> b -> c
	instance Lte Z b T
	instance (Lte a b l,If l b a c) => Max a b c

Wanted:	Max Z (S x) y

Then we'll reduce using the Max instance to:
	(Lte Z (S x) l, If l (S x) Z y)
610
and improve by binding l->T, after which we can do some reduction
611
612
613
on both the Lte and If constraints.  What we *can't* do is start again
with (Max Z (S x) y)!

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
[NO TYVARS]

	class Y a b | a -> b where
	    y :: a -> X b
	
	instance Y [[a]] a where
	    y ((x:_):_) = X x
	
	k :: X a -> X a -> X a

	g :: Num a => [X a] -> [X a]
	g xs = h xs
	    where
	    h ys = ys ++ map (k (y [[0]])) xs

The excitement comes when simplifying the bindings for h.  Initially
try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
From this we get t1:=:t2, but also various bindings.  We can't forget
the bindings (because of [LOOP]), but in fact t1 is what g is
633
634
635
polymorphic in.  

The net effect of [NO TYVARS] 
636

637
\begin{code}
638
639
isFreeWhenInferring :: TyVarSet -> Inst	-> Bool
isFreeWhenInferring qtvs inst
640
641
642
  =  isFreeWrtTyVars qtvs inst		-- Constrains no quantified vars
  && isInheritableInst inst		-- And no implicit parameter involved
					-- (see "Notes on implicit parameters")
643
644
645
646
647
648
649
650
651
652

isFreeWhenChecking :: TyVarSet	-- Quantified tyvars
	 	   -> NameSet	-- Quantified implicit parameters
		   -> Inst -> Bool
isFreeWhenChecking qtvs ips inst
  =  isFreeWrtTyVars qtvs inst
  && isFreeWrtIPs    ips inst

isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
653
\end{code}
654

655

656
657
658
659
660
%************************************************************************
%*									*
\subsection{tcSimplifyCheck}
%*									*
%************************************************************************
661

662
@tcSimplifyCheck@ is used when we know exactly the set of variables
663
we are going to quantify over.  For example, a class or instance declaration.
664
665

\begin{code}
666
tcSimplifyCheck
667
	 :: SDoc
668
669
	 -> [TcTyVar]		-- Quantify over these
	 -> [Inst]		-- Given
670
671
	 -> [Inst]		-- Wanted
	 -> TcM TcDictBinds	-- Bindings
672

673
-- tcSimplifyCheck is used when checking expression type signatures,
674
-- class decls, instance decls etc.
675
676
677
678
--
-- NB: tcSimplifyCheck does not consult the
--	global type variables in the environment; so you don't
--	need to worry about setting them before calling tcSimplifyCheck
679
tcSimplifyCheck doc qtvs givens wanted_lie
680
  = tcSimplCheck doc get_qtvs
681
682
		 givens wanted_lie	`thenM` \ (qtvs', binds) ->
    returnM binds
683
684
685
686
687
688
689
690
  where
    get_qtvs = zonkTcTyVarsAndFV qtvs


-- tcSimplifyInferCheck is used when we know the constraints we are to simplify
-- against, but we don't know the type variables over which we are going to quantify.
-- This happens when we have a type signature for a mutually recursive group
tcSimplifyInferCheck
691
	 :: SDoc
692
693
	 -> TcTyVarSet		-- fv(T)
	 -> [Inst]		-- Given
694
	 -> [Inst]		-- Wanted
695
696
697
698
	 -> TcM ([TcTyVar],	-- Variables over which to quantify
		 TcDictBinds)	-- Bindings

tcSimplifyInferCheck doc tau_tvs givens wanted_lie
699
  = tcSimplCheck doc get_qtvs givens wanted_lie
700
701
702
703
704
705
706
707
708
709
710
711
  where
	-- Figure out which type variables to quantify over
	-- You might think it should just be the signature tyvars,
	-- but in bizarre cases you can get extra ones
	-- 	f :: forall a. Num a => a -> a
	--	f x = fst (g (x, head [])) + 1
	--	g a b = (b,a)
	-- Here we infer g :: forall a b. a -> b -> (b,a)
	-- We don't want g to be monomorphic in b just because
	-- f isn't quantified over b.
    all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)

712
713
    get_qtvs = zonkTcTyVarsAndFV all_tvs	`thenM` \ all_tvs' ->
	       tcGetGlobalTyVars		`thenM` \ gbl_tvs ->
714
715
716
	       let
	          qtvs = all_tvs' `minusVarSet` gbl_tvs
			-- We could close gbl_tvs, but its not necessary for
717
			-- soundness, and it'll only affect which tyvars, not which
718
719
			-- dictionaries, we quantify over
	       in
720
	       returnM qtvs
721
722
723
724
\end{code}

Here is the workhorse function for all three wrappers.

725
\begin{code}
726
tcSimplCheck doc get_qtvs givens wanted_lie
727
  = check_loop givens wanted_lie	`thenM` \ (qtvs, frees, binds, irreds) ->
728

729
	-- Complain about any irreducible ones
730
731
    mappM zonkInst given_dicts_and_ips			 	`thenM` \ givens' ->
    groupErrs (addNoInstanceErrs (Just doc) givens') irreds	`thenM_`
732

733
	-- Done
734
    extendLIEs frees		`thenM_`
735
    returnM (qtvs, binds)
736

737
  where
738
739
740
741
    given_dicts_and_ips = filter (not . isMethod) givens
	-- For error reporting, filter out methods, which are 
	-- only added to the given set as an optimisation

742
743
    ip_set = mkNameSet (ipNamesOfInsts givens)

744
745
    check_loop givens wanteds
      =		-- Step 1
746
747
    	mappM zonkInst givens	`thenM` \ givens' ->
    	mappM zonkInst wanteds	`thenM` \ wanteds' ->
748
    	get_qtvs 		`thenM` \ qtvs' ->
749

750
751
752
753
 		    -- Step 2
    	let
 	    -- When checking against a given signature we always reduce
 	    -- until we find a match against something given, or can't reduce
754
755
 	    try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
 			| otherwise  			       = ReduceMe
756
    	in
757
    	reduceContext doc try_me givens' wanteds'	`thenM` \ (no_improvement, frees, binds, irreds) ->
758

759
760
 		    -- Step 3
    	if no_improvement then
761
 	    returnM (varSetElems qtvs', frees, binds, irreds)
762
    	else
763
764
 	    check_loop givens' (irreds ++ frees) 	`thenM` \ (qtvs', frees1, binds1, irreds1) ->
 	    returnM (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
765
766
767
\end{code}


768
769
770
771
772
773
774
775
%************************************************************************
%*									*
\subsection{tcSimplifyRestricted}
%*									*
%************************************************************************

\begin{code}
tcSimplifyRestricted 	-- Used for restricted binding groups
776
			-- i.e. ones subject to the monomorphism restriction
777
	:: SDoc
778
	-> TcTyVarSet		-- Free in the type of the RHSs
779
	-> [Inst]		-- Free in the RHSs
780
781
782
	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked)
		TcDictBinds)	-- Bindings

783
tcSimplifyRestricted doc tau_tvs wanteds
784
  = 	-- First squash out all methods, to find the constrained tyvars
785
   	-- We can't just take the free vars of wanted_lie because that'll
786
787
788
789
790
791
	-- have methods that may incidentally mention entirely unconstrained variables
	--  	e.g. a call to 	f :: Eq a => a -> b -> b
	-- Here, b is unconstrained.  A good example would be
	--	foo = f (3::Int)
	-- We want to infer the polymorphic type
	--	foo :: forall b. b -> b
792
793
794
795
796
797
798

	-- 'reduceMe': Reduce as far as we can.  Don't stop at
	-- dicts; the idea is to get rid of as many type
	-- variables as possible, and we don't want to stop
	-- at (say) Monad (ST s), because that reduces
	-- immediately, with no constraint on s.
    simpleReduceLoop doc reduceMe wanteds	`thenM` \ (foo_frees, foo_binds, constrained_dicts) ->
799
800

	-- Next, figure out the tyvars we will quantify over
801
802
    zonkTcTyVarsAndFV (varSetElems tau_tvs)	`thenM` \ tau_tvs' ->
    tcGetGlobalTyVars				`thenM` \ gbl_tvs ->
803
    let
804
	constrained_tvs = tyVarsOfInsts constrained_dicts
805
	qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs)
806
807
			 `minusVarSet` constrained_tvs
    in
808
809
810
811
    traceTc (text "tcSimplifyRestricted" <+> vcat [
		pprInsts wanteds, pprInsts foo_frees, pprInsts constrained_dicts,
		ppr foo_binds,
		ppr constrained_tvs, ppr tau_tvs', ppr qtvs ])	`thenM_`
812
813
814
815
816

	-- The first step may have squashed more methods than
	-- necessary, so try again, this time knowing the exact
	-- set of type variables to quantify over.
	--
817
	-- We quantify only over constraints that are captured by qtvs;
818
	-- these will just be a subset of non-dicts.  This in contrast
819
	-- to normal inference (using isFreeWhenInferring) in which we quantify over
820
	-- all *non-inheritable* constraints too.  This implements choice
821
	-- (B) under "implicit parameter and monomorphism" above.
822
823
824
825
	--
	-- Remember that we may need to do *some* simplification, to
	-- (for example) squash {Monad (ST s)} into {}.  It's not enough
	-- just to float all constraints
826
827
828
829
830
831
832
833
834
835
    restrict_loop doc qtvs wanteds
	-- We still need a loop because improvement can take place
	-- E.g. if we have (C (T a)) and the instance decl
	--	instance D Int b => C (T a) where ...
	-- and there's a functional dependency for D.   Then we may improve
	-- the tyep variable 'b'.

restrict_loop doc qtvs wanteds
  = mappM zonkInst wanteds			`thenM` \ wanteds' ->
    zonkTcTyVarsAndFV (varSetElems qtvs)	`thenM` \ qtvs' ->
836
    let
837
838
        try_me inst | isFreeWrtTyVars qtvs' inst = Free
	            | otherwise                  = ReduceMe
839
    in
840
    reduceContext doc try_me [] wanteds'	`thenM` \ (no_improvement, frees, binds, irreds) ->
841
842
843
844
845
846
847
    if no_improvement then
	ASSERT( null irreds )
	extendLIEs frees			`thenM_`
	returnM (varSetElems qtvs', binds)
    else
	restrict_loop doc qtvs' (irreds ++ frees)	`thenM` \ (qtvs1, binds1) ->
	returnM (qtvs1, binds `AndMonoBinds` binds1)
848
849
\end{code}

850
851
852
853
854
855
856

%************************************************************************
%*									*
\subsection{tcSimplifyToDicts}
%*									*
%************************************************************************

857
858
859
860
On the LHS of transformation rules we only simplify methods and constants,
getting dictionaries.  We want to keep all of them unsimplified, to serve
as the available stuff for the RHS of the rule.

861
The same thing is used for specialise pragmas. Consider
862

863
864
865
866
867
868
869
870
871
872
873
874
	f :: Num a => a -> a
	{-# SPECIALISE f :: Int -> Int #-}
	f = ...

The type checker generates a binding like:

	f_spec = (f :: Int -> Int)

and we want to end up with

	f_spec = _inline_me_ (f Int dNumInt)

875
But that means that we must simplify the Method for f to (f Int dNumInt)!
876
877
So tcSimplifyToDicts squeezes out all Methods.

878
879
880
881
882
IMPORTANT NOTE:  we *don't* want to do superclass commoning up.  Consider

	fromIntegral :: (Integral a, Num b) => a -> b
	{-# RULES "foo"  fromIntegral = id :: Int -> Int #-}

883
Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
884
885
886
887
888
889
890
891
892
893
894
895
want to get

	forall dIntegralInt.
	fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int

because the scsel will mess up matching.  Instead we want

	forall dIntegralInt, dNumInt.
	fromIntegral Int Int dIntegralInt dNumInt = id Int

Hence "DontReduce NoSCs"

896
\begin{code}
897
898
899
tcSimplifyToDicts :: [Inst] -> TcM (TcDictBinds)
tcSimplifyToDicts wanteds
  = simpleReduceLoop doc try_me wanteds		`thenM` \ (frees, binds, irreds) ->
900
	-- Since try_me doesn't look at types, we don't need to
901
	-- do any zonking, so it's safe to call reduceContext directly
902
    ASSERT( null frees )
903
904
    extendLIEs irreds		`thenM_`
    returnM binds
905

906
  where
907
    doc = text "tcSimplifyToDicts"
908
909

	-- Reduce methods and lits only; stop as soon as we get a dictionary
910
911
    try_me inst	| isDict inst = DontReduce NoSCs
		| otherwise   = ReduceMe
912
913
\end{code}

914

915
916
917
918
919
920
921
922
923
924
925

tcSimplifyBracket is used when simplifying the constraints arising from
a Template Haskell bracket [| ... |].  We want to check that there aren't
any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
Show instance), but we aren't otherwise interested in the results.
Nor do we care about ambiguous dictionaries etc.  We will type check
this bracket again at its usage site.

\begin{code}
tcSimplifyBracket :: [Inst] -> TcM ()
tcSimplifyBracket wanteds
926
  = simpleReduceLoop doc reduceMe wanteds	`thenM_`
927
928
    returnM ()
  where
929
    doc = text "tcSimplifyBracket"
930
931
932
\end{code}


933
934
935
936
937
938
939
940
941
942
%************************************************************************
%*									*
\subsection{Filtering at a dynamic binding}
%*									*
%************************************************************************

When we have
	let ?x = R in B

we must discharge all the ?x constraints from B.  We also do an improvement
943
step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
944
945
946
947
948
949

Actually, the constraints from B might improve the types in ?x. For example

	f :: (?x::Int) => Char -> Char
	let ?x = 3 in f 'c'

950
then the constraint (?x::Int) arising from the call to f will
951
force the binding for ?x to be of type Int.
952
953

\begin{code}
954
tcSimplifyIPs :: [Inst]		-- The implicit parameters bound here
955
956
957
958
959
960
	      -> [Inst]		-- Wanted
	      -> TcM TcDictBinds
tcSimplifyIPs given_ips wanteds
  = simpl_loop given_ips wanteds	`thenM` \ (frees, binds) ->
    extendLIEs frees			`thenM_`
    returnM binds
961
  where
962
963
    doc	     = text "tcSimplifyIPs" <+> ppr given_ips
    ip_set   = mkNameSet (ipNamesOfInsts given_ips)
964

965
	-- Simplify any methods that mention the implicit parameter
966
967
    try_me inst | isFreeWrtIPs ip_set inst = Free
		| otherwise		   = ReduceMe
968
969

    simpl_loop givens wanteds
970
971
      = mappM zonkInst givens		`thenM` \ givens' ->
        mappM zonkInst wanteds		`thenM` \ wanteds' ->
972

973
        reduceContext doc try_me givens' wanteds'    `thenM` \ (no_improvement, frees, binds, irreds) ->
974
975
976

        if no_improvement then
	    ASSERT( null irreds )
977
	    returnM (frees, binds)
978
	else
979
980
	    simpl_loop givens' (irreds ++ frees)	`thenM` \ (frees1, binds1) ->
	    returnM (frees1, binds `AndMonoBinds` binds1)
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
\end{code}


%************************************************************************
%*									*
\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
@LIE@), as well as the @HsBinds@ generated.

\begin{code}
1010
bindInstsOfLocalFuns ::	[Inst] -> [TcId] -> TcM TcMonoBinds
1011

1012
bindInstsOfLocalFuns wanteds local_ids
1013
  | null overloaded_ids
1014
	-- Common case
1015
1016
  = extendLIEs wanteds		`thenM_`
    returnM EmptyMonoBinds
1017
1018

  | otherwise
1019
  = simpleReduceLoop doc try_me wanteds		`thenM` \ (frees, binds, irreds) ->
1020
    ASSERT( null irreds )
1021
1022
    extendLIEs frees		`thenM_`
    returnM binds
1023
1024
1025
  where
    doc		     = text "bindInsts" <+> ppr local_ids
    overloaded_ids   = filter is_overloaded local_ids
1026
    is_overloaded id = isOverloadedTy (idType id)
1027
1028

    overloaded_set = mkVarSet overloaded_ids	-- There can occasionally be a lot of them
1029
						-- so it's worth building a set, so that
1030
1031
						-- lookup (in isMethodFor) is faster

1032
    try_me inst | isMethodFor overloaded_set inst = ReduceMe
1033
		| otherwise		          = Free
1034
\end{code}
1035

1036

1037
1038
%************************************************************************
%*									*
1039
\subsection{Data types for the reduction mechanism}
1040
1041
1042
%*									*
%************************************************************************

1043
1044
The main control over context reduction is here

1045
\begin{code}
1046
data WhatToDo
1047
1048
 = ReduceMe		-- Try to reduce this
			-- If there's no instance, behave exactly like
1049
1050
			-- DontReduce: add the inst to
			-- the irreductible ones, but don't
1051
1052
			-- produce an error message of any kind.
			-- It might be quite legitimate such as (Eq a)!
1053

1054
 | DontReduce WantSCs		-- Return as irreducible
1055
1056
1057

 | DontReduceUnlessConstant	-- Return as irreducible unless it can
				-- be reduced to a constant in one step
1058

1059
 | Free			  -- Return as free
1060

1061
1062
1063
reduceMe :: Inst -> WhatToDo
reduceMe inst = ReduceMe

1064
1065
data WantSCs = NoSCs | AddSCs	-- Tells whether we should add the superclasses
				-- of a predicate when adding it to the avails
1066
\end{code}
1067
1068
1069
1070



\begin{code}
1071
type Avails = FiniteMap Inst Avail
1072

1073
data Avail
1074
1075
  = IsFree		-- Used for free Insts
  | Irred		-- Used for irreducible dictionaries,
1076
1077
			-- which are going to be lambda bound

1078
  | Given TcId 		-- Used for dictionaries for which we have a binding
1079
			-- e.g. those "given" in a signature
1080
	  Bool		-- True <=> actually consumed (splittable IPs only)
1081
1082

  | NoRhs 		-- Used for Insts like (CCallable f)
1083
			-- where no witness is required.
1084
			-- ToDo: remove?
1085

1086
  | Rhs 		-- Used when there is a RHS
1087
1088
	TcExpr	 	-- The RHS
	[Inst]		-- Insts free in the RHS; we need these too
1089

1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
  | Linear 		-- Splittable Insts only.
	Int		-- The Int is always 2 or more; indicates how
			-- many copies are required
	Inst 		-- The splitter
	Avail		-- Where the "master copy" is

  | LinRhss		-- Splittable Insts only; this is used only internally
			-- 	by extractResults, where a Linear 
			--	is turned into an LinRhss
	[TcExpr]	-- A supply of suitable RHSs

1101
pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
1102
			| (inst,avail) <- fmToList avails ]
1103
1104
1105
1106

instance Outputable Avail where
    ppr = pprAvail

1107
1108
1109
1110
1111
1112
1113
1114
pprAvail NoRhs	       	= text "<no rhs>"
pprAvail IsFree	       	= text "Free"
pprAvail Irred	       	= text "Irred"
pprAvail (Given x b)   	= text "Given" <+> ppr x <+> 
		 	  if b then text "(used)" else empty
pprAvail (Rhs rhs bs)   = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
1115
1116
1117
1118
1119
1120
1121
1122
1123
\end{code}

Extracting the bindings from a bunch of Avails.
The bindings do *not* come back sorted in dependency order.
We assume that they'll be wrapped in a big Rec, so that the
dependency analyser can sort them out later

The loop startes
\begin{code}
1124
extractResults :: Avails
1125
	       -> [Inst]		-- Wanted
1126
	       -> TcM (TcDictBinds, 	-- Bindings
1127
1128
			  [Inst],	-- Irreducible ones
			  [Inst])	-- Free ones
1129

1130
1131
extractResults avails wanteds
  = go avails EmptyMonoBinds [] [] wanteds
1132
  where
1133
    go avails binds irreds frees [] 
1134
      = returnM (binds, irreds, frees)
1135

1136
    go avails binds irreds frees (w:ws)
1137
      = case lookupFM avails w of
1138
1139
	  Nothing    -> pprTrace "Urk: extractResults" (ppr w) $
			go avails binds irreds frees ws
1140

1141
1142
1143
	  Just NoRhs  -> go avails		 binds irreds     frees     ws
	  Just IsFree -> go (add_free avails w)  binds irreds     (w:frees) ws
	  Just Irred  -> go (add_given avails w) binds (w:irreds) frees     ws
1144

1145
	  Just (Given id _) -> go avails new_binds irreds frees ws
1146
			    where
1147
1148
1149
1150
			       new_binds | id == instToId w = binds
					 | otherwise        = addBind binds w (HsVar id)
		-- The sought Id can be one of the givens, via a superclass chain
		-- and then we definitely don't want to generate an x=x binding!
1151

1152
1153
1154
1155
	  Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
			     where
				new_binds = addBind binds w rhs

1156
	  Just (Linear n split_inst avail)	-- Transform Linear --> LinRhss
1157
1158
	    -> get_root irreds frees avail w		`thenM` \ (irreds', frees', root_id) ->
	       split n (instToId split_inst) root_id w	`thenM` \ (binds', rhss) ->
1159
1160
1161
1162
1163
	       go (addToFM avails w (LinRhss rhss))
		  (binds `AndMonoBinds` binds')
		  irreds' frees' (split_inst : w : ws)

	  Just (LinRhss (rhs:rhss))		-- Consume one of the Rhss
1164
1165
1166
1167
1168
		-> go new_avails new_binds irreds frees ws
		where		
		   new_binds  = addBind binds w rhs
		   new_avails = addToFM avails w (LinRhss rhss)

1169
1170
1171
1172
1173
    get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
    get_root irreds frees Irred	       w = cloneDict w	`thenM` \ w' ->
					   returnM (w':irreds, frees, instToId w')
    get_root irreds frees IsFree       w = cloneDict w	`thenM` \ w' ->
					   returnM (irreds, w':frees, instToId w')
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200

    add_given avails w 
	| instBindingRequired w = addToFM avails w (Given (instToId w) True)
	| otherwise		= addToFM avails w NoRhs
	-- NB: make sure that CCallable/CReturnable use NoRhs rather
	--	than Given, else we end up with bogus bindings.

    add_free avails w | isMethod w = avails
		      | otherwise  = add_given avails w
	-- NB: Hack alert!  
	-- Do *not* replace Free by Given if it's a method.
	-- The following situation shows why this is bad:
	--	truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
	-- From an application (truncate f i) we get
	--	t1 = truncate at f
	--	t2 = t1 at i
	-- If we have also have a second occurrence of truncate, we get
	--	t3 = truncate at f
	--	t4 = t3 at i
	-- When simplifying with i,f free, we might still notice that
	--   t1=t3; but alas, the binding for t2 (which mentions t1)
	--   will continue to float out!
	-- (split n i a) returns: n rhss
	--			  auxiliary bindings
	--			  1 or 0 insts to add to irreds


1201
split :: Int -> TcId -> TcId -> Inst 
1202
      -> TcM (TcDictBinds, [TcExpr])
1203
-- (split n split_id root_id wanted) returns
1204
1205
1206
1207
--	* a list of 'n' expressions, all of which witness 'avail'
--	* a bunch of auxiliary bindings to support these expressions
--	* one or zero insts needed to witness the whole lot
--	  (maybe be zero if the initial Inst is a Given)
1208
1209
1210
1211
--
-- NB: 'wanted' is just a template

split n split_id root_id wanted
1212
1213
  = go n
  where
1214
    ty      = linearInstType wanted
1215
    pair_ty = mkTyConApp pairTyCon [ty,ty]
1216
1217
1218
    id      = instToId wanted
    occ     = getOccName id
    loc     = getSrcLoc id
1219

1220
    go 1 = returnM (EmptyMonoBinds, [HsVar root_id])
1221

1222
1223
1224
    go n = go ((n+1) `div` 2)		`thenM` \ (binds1, rhss) ->
	   expand n rhss		`thenM` \ (binds2, rhss') ->
	   returnM (binds1 `AndMonoBinds` binds2, rhss')
1225
1226
1227
1228
1229
1230
1231
1232

	-- (expand n rhss) 
	-- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
	--  e.g.  expand 3 [rhs1, rhs2]
	--	  = ( { x = split rhs1 },
	--	      [fst x, snd x, rhs2] )
    expand n rhss
	| n `rem` 2 == 0 = go rhss 	-- n is even
1233
1234
	| otherwise  	 = go (tail rhss)	`thenM` \ (binds', rhss') ->
			   returnM (binds', head rhss : rhss')
1235
	where
1236
1237
	  go rhss = mapAndUnzipM do_one rhss	`thenM` \ (binds', rhss') ->
		    returnM (andMonoBindList binds', concat rhss')
1238

1239
1240
1241
	  do_one rhs = newUnique 			`thenM` \ uniq -> 
		       tcLookupId fstName		`thenM` \ fst_id ->
		       tcLookupId sndName		`thenM` \ snd_id ->
1242
1243
1244
		       let 
			  x = mkUserLocal occ uniq pair_ty loc
		       in
1245
		       returnM (VarMonoBind x (mk_app split_id rhs),
1246
1247
1248
1249
1250
1251
1252
				    [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])

mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var

mk_app id rhs = HsApp (HsVar id) rhs

addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs
1253
1254
1255
1256
1257
\end{code}


%************************************************************************
%*									*
1258
\subsection[reduce]{@reduce@}
1259
%*									*
1260
1261
%************************************************************************

1262
1263
1264
1265
1266
When the "what to do" predicate doesn't depend on the quantified type variables,
matters are easier.  We don't need to do any zonking, unless the improvement step
does something, in which case we zonk before iterating.

The "given" set is always empty.
1267

1268
\begin{code}
1269
1270
1271
simpleReduceLoop :: SDoc
	 	 -> (Inst -> WhatToDo)		-- What to do, *not* based on the quantified type variables
		 -> [Inst]			-- Wanted
1272
		 -> TcM ([Inst],		-- Free
simonpj's avatar