TcSimplify.lhs 117 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
5

6
TcSimplify
7
8

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

17
	tcSimplifyDeriv, tcSimplifyDefault,
18
	bindInstsOfLocalFuns, 
19
20
	
        tcSimplifyStagedExpr,
21
22

        misMatchMsg
23
24
    ) where

25
#include "HsVersions.h"
26

27
import {-# SOURCE #-} TcUnify( unifyType )
28
import HsSyn
29

30
import TcRnMonad
31
import TcHsSyn	( hsLPatType )
32
33
34
35
import Inst
import TcEnv
import InstEnv
import TcType
36
import TcMType
37
import TcIface
38
import TcTyFuns
39
import DsUtils	-- Big-tuple functions
40
import Var
41
import Id
42
43
44
45
46
47
48
49
50
import Name
import NameSet
import Class
import FunDeps
import PrelInfo
import PrelNames
import TysWiredIn
import ErrUtils
import BasicTypes
51
import VarSet
52
import VarEnv
53
import FiniteMap
54
import Bag
55
import Outputable
56
57
58
59
import ListSetOps
import Util
import SrcLoc
import DynFlags
60
import FastString
61

Ian Lynagh's avatar
Ian Lynagh committed
62
import Control.Monad
63
import Data.List
64
65
66
67
68
\end{code}


%************************************************************************
%*									*
69
\subsection{NOTES}
70
71
72
%*									*
%************************************************************************

73
74
75
76
	--------------------------------------
	Notes on functional dependencies (a bug)
	--------------------------------------

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Consider this:

	class C a b | a -> b
	class D a b | a -> b

	instance D a b => C a b	-- Undecidable 
				-- (Not sure if it's crucial to this eg)
	f :: C a b => a -> Bool
	f _ = True
	
	g :: C a b => a -> Bool
	g = f

Here f typechecks, but g does not!!  Reason: before doing improvement,
we reduce the (C a b1) constraint from the call of f to (D a b1).

Here is a more complicated example:

Thomas Schilling's avatar
Thomas Schilling committed
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
@
  > class Foo a b | a->b
  >
  > class Bar a b | a->b
  >
  > data Obj = Obj
  >
  > instance Bar Obj Obj
  >
  > instance (Bar a b) => Foo a b
  >
  > foo:: (Foo a b) => a -> String
  > foo _ = "works"
  >
  > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
  > runFoo f = f Obj

  *Test> runFoo foo

  <interactive>:1:
      Could not deduce (Bar a b) from the context (Foo a b)
        arising from use of `foo' at <interactive>:1
      Probable fix:
          Add (Bar a b) to the expected type of an expression
      In the first argument of `runFoo', namely `foo'
      In the definition of `it': it = runFoo foo

  Why all of the sudden does GHC need the constraint Bar a b? The
  function foo didn't ask for that...
@
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

The trouble is that to type (runFoo foo), GHC has to solve the problem:

	Given constraint	Foo a b
	Solve constraint	Foo a b'

Notice that b and b' aren't the same.  To solve this, just do
improvement and then they are the same.  But GHC currently does
	simplify constraints
	apply improvement
	and loop

That is usually fine, but it isn't here, because it sees that Foo a b is
not the same as Foo a b', and so instead applies the instance decl for
instance Bar a b => Foo a b.  And that's where the Bar constraint comes
from.

The Right Thing is to improve whenever the constraint set changes at
all.  Not hard in principle, but it'll take a bit of fiddling to do.  

145
146
147
Note [Choosing which variables to quantify]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we are about to do a generalisation step.  We have in our hand
148
149
150

	G	the environment
	T	the type of the RHS
151
	C	the constraints from that RHS
152
153
154
155
156
157
158
159
160
161
162

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

163
and float the constraints Ct further outwards.
164
165
166
167
168
169

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

170
171
172
173
174
175
 (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.
176
177
178
179
180
181
182
183
184
185
186
187
188

	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}

189
190
191
192
193
In particular, it's perfectly OK to quantify over more type variables
than strictly necessary; there is no need to quantify over 'b', since
it is determined by 'a' which is free in the envt, but it's perfectly
OK to do so.  However we must not quantify over 'a' itself.

194
195
Other things being equal, however, we'd like to quantify over as few
variables as possible: smaller types, fewer type applications, more
196
197
constraints can get into Ct instead of Cq.  Here's a good way to
choose Q:
198
199
200
201
202
203
204
205
206
207
208

	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 ...
209

210
211
212
213
214
215
216
	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

217
  And then if the fn was called at several different c's, each of
218
219
220
221
222
223
224
225
226
227
228
229
230
  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))

231
232
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.
233
234
235
236
237
238
239

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.



simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
240
241
242
-------------------------------------
	Note [Ambiguity]
-------------------------------------
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281

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.

282
So here's the plan.  We WARN about probable ambiguity if
283
284
285
286
287

	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
288
in the environment, or by the variables in the type.
289
290
291

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

292
	class J a b c | a b -> c
293
294
295
	fv(G) = {a}

Is this ambiguous?
296
	forall b c. (J a b c) => b -> b
297
298

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

301
It's a bit vague exactly which C we should use for this oclose call.  If we
302
303
304
305
306
307
308
309
310
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

311
then c is a "bubble"; there's no way it can ever improve, and it's
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
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.
330
The definitely-ambiguous can then float out, and get smashed at top level
331
332
333
(which squashes out the constants, like Eq (T a) above)


334
	--------------------------------------
335
		Notes on principal types
336
	--------------------------------------
337
338
339

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

341
342
343
344
345
346
347
    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


348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
	--------------------------------------
	The need for forall's in constraints
	--------------------------------------

[Exchange on Haskell Cafe 5/6 Dec 2000]

  class C t where op :: t -> Bool
  instance C [t] where op x = True

  p y = (let f :: c -> Bool; f x = op (y >> return x) in f, y ++ [])
  q y = (y ++ [], let f :: c -> Bool; f x = op (y >> return x) in f)

The definitions of p and q differ only in the order of the components in
the pair on their right-hand sides.  And yet:

  ghc and "Typing Haskell in Haskell" reject p, but accept q;
  Hugs rejects q, but accepts p;
  hbc rejects both p and q;
  nhc98 ... (Malcolm, can you fill in the blank for us!).

The type signature for f forces context reduction to take place, and
the results of this depend on whether or not the type of y is known,
which in turn depends on which component of the pair the type checker
analyzes first.  

Solution: if y::m a, float out the constraints
	Monad m, forall c. C (m c)
When m is later unified with [], we can solve both constraints.


378
	--------------------------------------
379
		Notes on implicit parameters
380
	--------------------------------------
381

382
383
Note [Inheriting implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384
385
386
Consider this:

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

388
389
390
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:
391

392
393
394
	f :: Int -> Int

(so we get ?y from the context of f's definition), or
395
396
397

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

398
399
400
401
402
403
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.

404
405
BOTTOM LINE: when *inferring types* you *must* quantify 
over implicit parameters. See the predicate isFreeWhenInferring.
406

407

408
409
Note [Implicit parameters and ambiguity] 
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
410
411
412
413
414
415
416
417
418
419
420
421
422
Only a *class* predicate can give rise to ambiguity
An *implicit parameter* cannot.  For example:
	foo :: (?x :: [a]) => Int
	foo = length ?x
is fine.  The call site will suppply a particular 'x'

Furthermore, the type variables fixed by an implicit parameter
propagate to the others.  E.g.
	foo :: (Show a, ?x::[a]) => Int
	foo = show (?x++?x)
The type of foo looks ambiguous.  But it isn't, because at a call site
we might have
	let ?x = 5::Int in foo
423
424
425
426
427
and all is well.  In effect, implicit parameters are, well, parameters,
so we can take their type variables into account as part of the
"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.


428
429
430
431
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:
432
433
434
435
436
437
438
439
440
441
442

	(?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).
443

444
445
446
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:
447

448
	f :: Int -> Int
449
	f x = (x::Int) + ?y
450

451
At first sight this seems reasonable, but it has the nasty property
452
that adding a type signature changes the dynamic semantics.
453
Consider this:
454

455
	(let f x = (x::Int) + ?y
456
457
458
459
 	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+5)
vs
460
	(let f :: Int -> Int
461
	     f x = x + ?y
462
463
464
465
	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+6)

466
467
Indeed, simply inlining f (at the Haskell source level) would change the
dynamic semantics.
468

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
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.
496

497

498
499
500
Question 3: monomorphism
~~~~~~~~~~~~~~~~~~~~~~~~
There's a nasty corner case when the monomorphism restriction bites:
501

502
503
	z = (x::Int) + ?y

504
505
The argument above suggests that we *must* generalise
over the ?y parameter, to get
506
507
	z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
508
	z :: Int.
509
510
511
512
513
514
515
516
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.


517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
Question 4: top level
~~~~~~~~~~~~~~~~~~~~~
At the top level, monomorhism makes no sense at all.

    module Main where
	main = let ?x = 5 in print foo

	foo = woggle 3

	woggle :: (?x :: Int) => Int -> Int
	woggle y = ?x + y

We definitely don't want (foo :: Int) with a top-level implicit parameter
(?x::Int) becuase there is no way to bind it.  

532
533
534
535
536
537
538
539

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

    Consequences:
540
	* Inlining remains valid
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
	* 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.
578

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

581
	z = (x::Int) + ?y
582

583
584
585
586
587
588
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.
589

590
Choice (C) really says "the monomorphism restriction doesn't apply
591
to implicit parameters".  Which is fine, but remember that every
592
593
594
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'
595
clauses that bind ?y, so a decent compiler should common up all
596
597
598
those function calls.  So I think I strongly favour (C).  Indeed,
one could make a similar argument for abolishing the monomorphism
restriction altogether.
599

600
BOTTOM LINE: we choose (B) at present.  See tcSimplifyRestricted
601

602

603

604
605
606
607
608
609
610
611
612
%************************************************************************
%*									*
\subsection{tcSimplifyInfer}
%*									*
%************************************************************************

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

    1. Compute Q = grow( fvs(T), C )
613
614

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

617
    3. Try improvement, using functional dependencies
618

619
620
621
622
    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
623
Eq (a,b), we don't simplify to (Eq a, Eq b).  So Q won't be different
624
625
626
627
628
629
630
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 ...
631

632
633
634
635
636
637
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
638
again.
639

640
641

\begin{code}
642
tcSimplifyInfer
643
644
	:: SDoc
	-> TcTyVarSet		-- fv(T); type vars
645
	-> [Inst]		-- Wanted
646
	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked and quantified)
647
648
		[Inst],		-- Dict Ids that must be bound here (zonked)
		TcDictBinds)	-- Bindings
649
	-- Any free (escaping) Insts are tossed into the environment
650
\end{code}
651

652
653

\begin{code}
654
tcSimplifyInfer doc tau_tvs wanted
655
  = do	{ tau_tvs1 <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
656
	; wanted'  <- mapM zonkInst wanted	-- Zonk before deciding quantified tyvars
657
	; gbl_tvs  <- tcGetGlobalTyVars
658
659
	; let preds1   = fdPredsOfInsts wanted'
	      gbl_tvs1 = oclose preds1 gbl_tvs
660
	      qtvs     = growInstsTyVars wanted' tau_tvs1 `minusVarSet` gbl_tvs1
661
662
663
664
			-- See Note [Choosing which variables to quantify]

		-- To maximise sharing, remove from consideration any 
		-- constraints that don't mention qtvs at all
665
666
	; let (free, bound) = partition (isFreeWhenInferring qtvs) wanted'
	; extendLIEs free
667

668
		-- To make types simple, reduce as much as possible
669
	; traceTc (text "infer" <+> (ppr preds1 $$ ppr (growInstsTyVars wanted' tau_tvs1) $$ ppr gbl_tvs $$ 
670
		   ppr gbl_tvs1 $$ ppr free $$ ppr bound))
671
	; (irreds1, binds1) <- tryHardCheckLoop doc bound
672
673

		-- Note [Inference and implication constraints]
674
675
	; let want_dict d = tyVarsOfInst d `intersectsVarSet` qtvs
	; (irreds2, binds2) <- approximateImplications doc want_dict irreds1
676

677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
		-- Now work out all over again which type variables to quantify,
		-- exactly in the same way as before, but starting from irreds2.  Why?
		-- a) By now improvment may have taken place, and we must *not*
		--    quantify over any variable free in the environment
		--    tc137 (function h inside g) is an example
		--
		-- b) Do not quantify over constraints that *now* do not
		--    mention quantified type variables, because they are
		--    simply ambiguous (or might be bound further out).  Example:
		--    	f :: Eq b => a -> (a, b)
		--    	g x = fst (f x)
		--    From the RHS of g we get the MethodInst f77 :: alpha -> (alpha, beta)
		--    We decide to quantify over 'alpha' alone, but free1 does not include f77
		--    because f77 mentions 'alpha'.  Then reducing leaves only the (ambiguous)
		--    constraint (Eq beta), which we dump back into the free set
		--    See test tcfail181
		--
		-- c) irreds may contain type variables not previously mentioned,
		--    e.g.  instance D a x => Foo [a] 
		--	    wanteds = Foo [a]
		--       Then after simplifying we'll get (D a x), and x is fresh
		-- 	 We must quantify over x else it'll be totally unbound
	; tau_tvs2 <- zonkTcTyVarsAndFV (varSetElems tau_tvs1)
700
701
702
703
704
705
706
707
708
709
	; gbl_tvs2 <- zonkTcTyVarsAndFV (varSetElems gbl_tvs1)
		-- Note that we start from gbl_tvs1
		-- We use tcGetGlobalTyVars, then oclose wrt preds2, because
		-- we've already put some of the original preds1 into frees
		-- E.g. 	wanteds = C a b	  (where a->b)
		--		gbl_tvs = {a}
		--		tau_tvs = {b}
		-- Then b is fixed by gbl_tvs, so (C a b) will be in free, and
		-- irreds2 will be empty.  But we don't want to generalise over b!
	; let preds2 = fdPredsOfInsts irreds2	-- irreds2 is zonked
710
	      qtvs   = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
711
712
713
714
715
716
		---------------------------------------------------
		-- BUG WARNING: there's a nasty bug lurking here
		-- fdPredsOfInsts may return preds that mention variables quantified in
		-- one of the implication constraints in irreds2; and that is clearly wrong:
		-- we might quantify over too many variables through accidental capture
		---------------------------------------------------
717
718
719
720
721
722
	; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2
	; extendLIEs free

		-- Turn the quantified meta-type variables into real type variables
	; qtvs2 <- zonkQuantifiedTyVars (varSetElems qtvs)

723
724
		-- We can't abstract over any remaining unsolved 
		-- implications so instead just float them outwards. Ugh.
725
	; let (q_dicts0, implics) = partition isAbstractableInst irreds3
726
	; loc <- getInstLoc (ImplicOrigin doc)
727
728
729
730
	; implic_bind <- bindIrreds loc qtvs2 q_dicts0 implics

		-- Prepare equality instances for quantification
	; let (q_eqs0,q_dicts) = partition isEqInst q_dicts0
731
	; q_eqs <- mapM finalizeEqInst q_eqs0
732

733
	; return (qtvs2, q_eqs ++ q_dicts, binds1 `unionBags` binds2 `unionBags` implic_bind) }
734
735
	-- NB: when we are done, we might have some bindings, but
	-- the final qtvs might be empty.  See Note [NO TYVARS] below.
736

737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
approximateImplications :: SDoc -> (Inst -> Bool) -> [Inst] -> TcM ([Inst], TcDictBinds)
-- Note [Inference and implication constraints]
-- Given a bunch of Dict and ImplicInsts, try to approximate the implications by
--	- fetching any dicts inside them that are free
--	- using those dicts as cruder constraints, to solve the implications
--	- returning the extra ones too

approximateImplications doc want_dict irreds
  | null extra_dicts 
  = return (irreds, emptyBag)
  | otherwise
  = do	{ extra_dicts' <- mapM cloneDict extra_dicts
	; tryHardCheckLoop doc (extra_dicts' ++ irreds) }
		-- By adding extra_dicts', we make them 
		-- available to solve the implication constraints
  where 
    extra_dicts = get_dicts (filter isImplicInst irreds)

    get_dicts :: [Inst] -> [Inst]	-- Returns only Dicts
	-- Find the wanted constraints in implication constraints that satisfy
	-- want_dict, and are not bound by forall's in the constraint itself
    get_dicts ds = concatMap get_dict ds

    get_dict d@(Dict {}) | want_dict d = [d]
		         | otherwise   = []
    get_dict (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
763
	= [ d | let tv_set = mkVarSet tvs
764
	      , d <- get_dicts wanteds 
765
	      , not (tyVarsOfInst d `intersectsVarSet` tv_set)]
766
767
    get_dict i@(EqInst {}) | want_dict i = [i]
			   | otherwise   = [] 
768
    get_dict other = pprPanic "approximateImplications" (ppr other)
769
\end{code}
770

771
772
Note [Inference and implication constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
773
774
775
776
777
778
779
780
781
782
783
784
785
Suppose we have a wanted implication constraint (perhaps arising from
a nested pattern match) like
	C a => D [a]
and we are now trying to quantify over 'a' when inferring the type for
a function.  In principle it's possible that there might be an instance
	instance (C a, E a) => D [a]
so the context (E a) would suffice.  The Right Thing is to abstract over
the implication constraint, but we don't do that (a) because it'll be
surprising to programmers and (b) because we don't have the machinery to deal
with 'given' implications.

So our best approximation is to make (D [a]) part of the inferred
context, so we can use that to discharge the implication. Hence
786
the strange function get_dicts in approximateImplications.
787
788
789
790
791
792

The common cases are more clear-cut, when we have things like
	forall a. C a => C b
Here, abstracting over (C b) is not an approximation at all -- but see
Note [Freeness and implications].
 
793
794
795
See Trac #1430 and test tc228.


796
797
798
799
800
801
802
803
804
805
806
807
808
809
\begin{code}
-----------------------------------------------------------
-- 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
	 :: InstLoc
	 -> TcTyVarSet		-- fv(T)
	 -> [Inst]		-- Given
	 -> [Inst]		-- Wanted
	 -> TcM ([TyVar],	-- Fully zonked, and quantified
		 TcDictBinds)	-- Bindings

tcSimplifyInferCheck loc tau_tvs givens wanteds
810
  = do	{ traceTc (text "tcSimplifyInferCheck <-" <+> ppr wanteds)
811
	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834

	-- 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.
	; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
	; all_tvs <- zonkTcTyVarsAndFV all_tvs
	; gbl_tvs <- tcGetGlobalTyVars
	; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs)
		-- We could close gbl_tvs, but its not necessary for
		-- soundness, and it'll only affect which tyvars, not which
		-- dictionaries, we quantify over

	; qtvs' <- zonkQuantifiedTyVars qtvs

		-- Now we are back to normal (c.f. tcSimplCheck)
	; implic_bind <- bindIrreds loc qtvs' givens irreds

835
	; traceTc (text "tcSimplifyInferCheck ->" <+> ppr (implic_bind))
836
837
838
	; return (qtvs', binds `unionBags` implic_bind) }
\end{code}

839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
Note [Squashing methods]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful if you want to float methods more:
	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)
may continue to float out!


Note [NO TYVARS]
~~~~~~~~~~~~~~~~~
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
	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}.
871
From this we get t1~t2, but also various bindings.  We can't forget
872
the bindings (because of [LOOP]), but in fact t1 is what g is
873
874
875
polymorphic in.  

The net effect of [NO TYVARS] 
876

877
\begin{code}
878
879
isFreeWhenInferring :: TyVarSet -> Inst	-> Bool
isFreeWhenInferring qtvs inst
880
881
882
  =  isFreeWrtTyVars qtvs inst	-- Constrains no quantified vars
  && isInheritableInst inst	-- and no implicit parameter involved
				--   see Note [Inheriting implicit parameters]
883

884
{-	No longer used (with implication constraints)
885
886
887
888
889
890
isFreeWhenChecking :: TyVarSet	-- Quantified tyvars
	 	   -> NameSet	-- Quantified implicit parameters
		   -> Inst -> Bool
isFreeWhenChecking qtvs ips inst
  =  isFreeWrtTyVars qtvs inst
  && isFreeWrtIPs    ips inst
891
-}
892

Ian Lynagh's avatar
Ian Lynagh committed
893
isFreeWrtTyVars :: VarSet -> Inst -> Bool
894
isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
Ian Lynagh's avatar
Ian Lynagh committed
895
isFreeWrtIPs :: NameSet -> Inst -> Bool
896
isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
897
\end{code}
898

899

900
901
902
903
904
%************************************************************************
%*									*
\subsection{tcSimplifyCheck}
%*									*
%************************************************************************
905

906
@tcSimplifyCheck@ is used when we know exactly the set of variables
907
we are going to quantify over.  For example, a class or instance declaration.
908
909

\begin{code}
910
-----------------------------------------------------------
911
-- tcSimplifyCheck is used when checking expression type signatures,
912
-- class decls, instance decls etc.
913
914
915
916
917
918
tcSimplifyCheck	:: InstLoc
	 	-> [TcTyVar]		-- Quantify over these
	 	-> [Inst]		-- Given
	 	-> [Inst]		-- Wanted
	 	-> TcM TcDictBinds	-- Bindings
tcSimplifyCheck loc qtvs givens wanteds 
919
  = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
920
921
    do	{ traceTc (text "tcSimplifyCheck")
      	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
922
	; implic_bind <- bindIrreds loc qtvs givens irreds
923
924
925
926
927
928
929
930
931
	; return (binds `unionBags` implic_bind) }

-----------------------------------------------------------
-- tcSimplifyCheckPat is used for existential pattern match
tcSimplifyCheckPat :: InstLoc
	 	   -> [TcTyVar]		-- Quantify over these
	 	   -> [Inst]		-- Given
	 	   -> [Inst]		-- Wanted
	 	   -> TcM TcDictBinds	-- Bindings
932
tcSimplifyCheckPat loc qtvs givens wanteds
933
  = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
934
935
    do	{ traceTc (text "tcSimplifyCheckPat")
      	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
936
	; implic_bind <- bindIrredsR loc qtvs givens irreds
937
938
939
	; return (binds `unionBags` implic_bind) }

-----------------------------------------------------------
940
941
942
943
bindIrreds :: InstLoc -> [TcTyVar]
	   -> [Inst] -> [Inst]
	   -> TcM TcDictBinds
bindIrreds loc qtvs givens irreds 
944
  = bindIrredsR loc qtvs givens irreds
945

946
bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds	
947
948
-- Make a binding that binds 'irreds', by generating an implication
-- constraint for them, *and* throwing the constraint into the LIE
949
bindIrredsR loc qtvs givens irreds
950
951
952
  | null irreds
  = return emptyBag
  | otherwise
953
954
955
956
  = do	{ let givens' = filter isAbstractableInst givens
		-- The givens can (redundantly) include methods
		-- We want to retain both EqInsts and Dicts
		-- There should be no implicadtion constraints
957
		-- See Note [Pruning the givens in an implication constraint]
958

959
	   -- If there are no 'givens', then it's safe to 
960
961
	   -- partition the 'wanteds' by their qtvs, thereby trimming irreds
	   -- See Note [Freeness and implications]
962
	; irreds' <- if null givens'
963
964
965
966
967
968
969
	     	     then do
	     	    	{ let qtv_set = mkVarSet qtvs
	     	    	      (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds
	     	    	; extendLIEs frees
	     	    	; return real_irreds }
	     	     else return irreds
	
970
	; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds'
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
971
972
			-- This call does the real work
			-- If irreds' is empty, it does something sensible
973
974
	; extendLIEs implics
	; return bind } 
975
976


977
makeImplicationBind :: InstLoc -> [TcTyVar]
978
979
980
		    -> [Inst] -> [Inst]
		    -> TcM ([Inst], TcDictBinds)
-- Make a binding that binds 'irreds', by generating an implication
981
982
-- constraint for them.
--
983
984
985
-- The binding looks like
--	(ir1, .., irn) = f qtvs givens
-- where f is (evidence for) the new implication constraint
986
--	f :: forall qtvs. givens => (ir1, .., irn)
987
-- qtvs includes coercion variables
988
989
--
-- This binding must line up the 'rhs' in reduceImplication
990
makeImplicationBind loc all_tvs
991
		    givens 	-- Guaranteed all Dicts or EqInsts
992
993
994
995
996
		    irreds
 | null irreds			-- If there are no irreds, we are done
 = return ([], emptyBag)
 | otherwise			-- Otherwise we must generate a binding
 = do	{ uniq <- newUnique 
997
	; span <- getSrcSpanM
998
	; let (eq_givens, dict_givens) = partition isEqInst givens
999

1000
1001
1002
1003
1004
                -- extract equality binders
              eq_cotvs = map eqInstType eq_givens

                -- make the implication constraint instance
	      name = mkInternalName uniq (mkVarOcc "ic") span
1005
	      implic_inst = ImplicInst { tci_name = name,
1006
					 tci_tyvars = all_tvs, 
1007
					 tci_given = eq_givens ++ dict_givens,
1008
1009
1010
1011
1012
1013
                                                       -- same order as binders
					 tci_wanted = irreds, 
                                         tci_loc = loc }

	        -- create binders for the irreducible dictionaries
	      dict_irreds    = filter (not . isEqInst) irreds
1014
	      dict_irred_ids = map instToId dict_irreds
1015
	      lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
1016
1017
1018
1019
1020
1021
1022

                -- create the binding
	      rhs  = L span (mkHsWrap co (HsVar (instToId implic_inst)))
	      co   =     mkWpApps (map instToId dict_givens)
		     <.> mkWpTyApps eq_cotvs
		     <.> mkWpTyApps (mkTyVarTys all_tvs)
	      bind | [dict_irred_id] <- dict_irred_ids  
Simon Marlow's avatar
Simon Marlow committed
1023
                   = VarBind dict_irred_id rhs
1024
		   | otherwise        
Simon Marlow's avatar
Simon Marlow committed
1025
                   = PatBind { pat_lhs = lpat
1026
1027
1028
1029
1030
			     , pat_rhs = unguardedGRHSs rhs 
			     , pat_rhs_ty = hsLPatType lpat
			     , bind_fvs = placeHolderNames 
                             }

1031
	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
Simon Marlow's avatar
Simon Marlow committed
1032
	; return ([implic_inst], unitBag (L span bind)) 
1033
        }
1034
1035

-----------------------------------------------------------
1036
tryHardCheckLoop :: SDoc
1037
	     -> [Inst]			-- Wanted
1038
	     -> TcM ([Inst], TcDictBinds)
1039

1040
tryHardCheckLoop doc wanteds
1041
  = do { (irreds,binds) <- checkLoop (mkInferRedEnv doc try_me) wanteds
1042
1043
       ; return (irreds,binds)
       }
1044
  where
1045
    try_me _ = ReduceMe
1046
	-- Here's the try-hard bit
1047
1048

-----------------------------------------------------------
1049
gentleCheckLoop :: InstLoc
1050
1051
	       -> [Inst]		-- Given
	       -> [Inst]		-- Wanted
1052
	       -> TcM ([Inst], TcDictBinds)
1053

1054
gentleCheckLoop inst_loc givens wanteds
1055
  = do { (irreds,binds) <- checkLoop env wanteds
1056
1057
       ; return (irreds,binds)
       }
1058
1059
1060
  where
    env = mkRedEnv (pprInstLoc inst_loc) try_me givens

1061
    try_me inst | isMethodOrLit inst = ReduceMe
1062
		| otherwise	     = Stop
1063
1064
	-- When checking against a given signature 
	-- we MUST be very gentle: Note [Check gently]
1065
1066
1067
1068

gentleInferLoop :: SDoc -> [Inst]
	        -> TcM ([Inst], TcDictBinds)
gentleInferLoop doc wanteds
1069
  = do 	{ (irreds, binds) <- checkLoop env wanteds
1070
1071
	; return (irreds, binds) }
  where
1072
1073
    env = mkInferRedEnv doc try_me
    try_me inst | isMethodOrLit inst = ReduceMe
1074
		| otherwise	     = Stop
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
\end{code}

Note [Check gently]
~~~~~~~~~~~~~~~~~~~~
We have to very careful about not simplifying too vigorously
Example:  
  data T a where
    MkT :: a -> T [a]

  f :: Show b => T b -> b
  f (MkT x) = show [x]

Inside the pattern match, which binds (a:*, x:a), we know that
	b ~ [a]
Hence we have a dictionary for Show [a] available; and indeed we 
need it.  We are going to build an implication contraint
	forall a. (b~[a]) => Show [a]
1092
Later, we will solve this constraint using the knowledge (Show b)
1093
1094
1095
1096
1097
	
But we MUST NOT reduce (Show [a]) to (Show a), else the whole
thing becomes insoluble.  So we simplify gently (get rid of literals
and methods only, plus common up equal things), deferring the real
work until top level, when we solve the implication constraint
1098
with tryHardCheckLooop.
1099
1100
1101
1102
1103
1104


\begin{code}
-----------------------------------------------------------
checkLoop :: RedEnv
	  -> [Inst]			-- Wanted
1105
	  -> TcM ([Inst], TcDictBinds) 
1106
-- Precondition: givens are completely rigid
1107
-- Postcondition: returned Insts are zonked
1108
1109

checkLoop env wanteds
1110
1111
  = go env wanteds
  where go env wanteds
1112
	  = do  {  -- We do need to zonk the givens; cf Note [Zonking RedEnv]
1113
1114
                ; env'     <- zonkRedEnv env
		; wanteds' <- zonkInsts  wanteds
1115
	
1116
1117
1118
		; (improved, tybinds, binds, irreds) 
                    <- reduceContext env' wanteds'
                ; execTcTyVarBinds tybinds
1119

1120
		; if null irreds || not improved then
1121
	 	    return (irreds, binds)
1122
1123
1124
1125
		  else do
	
		-- If improvement did some unification, we go round again.
		-- We start again with irreds, not wanteds
1126
1127
1128
1129
		-- 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 Note [LOOP]
1130
		{ (irreds1, binds1) <- go env' irreds
1131
		; return (irreds1, binds `unionBags` binds1) } }
1132
\end{code}
1133

1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
Note [Zonking RedEnv]
~~~~~~~~~~~~~~~~~~~~~
It might appear as if the givens in RedEnv are always rigid, but that is not
necessarily the case for programs involving higher-rank types that have class
contexts constraining the higher-rank variables.  An example from tc237 in the
testsuite is

  class Modular s a | s -> a

  wim ::  forall a w. Integral a 
                        => a -> (forall s. Modular s a => M s w) -> w
  wim i k = error "urk"

  test5  ::  (Modular s a, Integral a) => M s a
  test5  =   error "urk"

  test4   =   wim 4 test4'

Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is
quantified further outside.  When type checking test4, we have to check
whether the signature of test5 is an instance of 

  (forall s. Modular s a => M s w)

Consequently, we will get (Modular s t_a), where t_a is a TauTv into the
givens. 

Given the FD of Modular in this example, class improvement will instantiate
t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
Modular s a predicate in that signature).  If we don't zonk (Modular s t_a) in
the givens, we will get into a loop as improveOne uses the unification engine
1165
Unify.tcUnifyTys, which doesn't know about mutable type variables.
1166
1167


1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
Note [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)
and improve by binding l->T, after which we can do some reduction
on both the Lte and If constraints.  What we *can't* do is start again
with (Max Z (S x) y)!

1185

1186

1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
%************************************************************************
%*									*
		tcSimplifySuperClasses
%*									*
%************************************************************************

Note [SUPERCLASS-LOOP 1]
~~~~~~~~~~~~~~~~~~~~~~~~
We have to be very, very careful when generating superclasses, lest we
accidentally build a loop. Here's an example:

  class S a

  class S a => C a where { opc :: a -> a }
  class S b => D b where { opd :: b -> b }
  
  instance C Int where
     opc = opd
  
  instance D Int where
     opd = opc

From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
Simplifying, we may well get:
	$dfCInt = :C ds1 (opd dd)
	dd  = $dfDInt
	ds1 = $p1 dd
Notice that we spot that we can extract ds1 from dd.  

Alas!  Alack! We can do the same for (instance D Int):

	$dfDInt = :D ds2 (opc dc)
	dc  = $dfCInt
	ds2 = $p1 dc

And now we've defined the superclass in terms of itself.
Two more nasty cases are in
	tcrun021
	tcrun033

1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
Solution: 
  - Satisfy the superclass context *all by itself* 
    (tcSimplifySuperClasses)
  - And do so completely; i.e. no left-over constraints
    to mix with the constraints arising from method declarations


Note [Recursive instances and superclases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this code, which arises in the context of "Scrap Your 
Boilerplate with Class".  

    class Sat a
    class Data ctx a
    instance  Sat (ctx Char)             => Data ctx Char
    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]

    class Data Maybe a => Foo a

    instance Foo t => Sat (Maybe t)

    instance Data Maybe a => Foo a
    instance Foo a        => Foo [a]
    instance                 Foo [Char]

In the instance for Foo [a], when generating evidence for the superclasses
(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]).
Using the instance for Data, we therefore need
        (Sat (Maybe [a], Data Maybe a)
But we are given (Foo a), and hence its superclass (Data Maybe a).
So that leaves (Sat (Maybe [a])).  Using the instance for Sat means
we need (Foo [a]).  And that is the very dictionary we are bulding
an instance for!  So we must put that in the "givens".  So in this
case we have
	Given:  Foo a, Foo [a]
	Watend: Data Maybe [a]

BUT we must *not not not* put the *superclasses* of (Foo [a]) in
the givens, which is what 'addGiven' would normally do. Why? Because
(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted 
by selecting a superclass from Foo [a], which simply makes a loop.

On the other hand we *must* put the superclasses of (Foo a) in
the givens, as you can see from the derivation described above.

Conclusion: in the very special case of tcSimplifySuperClasses
we have one 'given' (namely the "this" dictionary) whose superclasses
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
must not be added to 'givens' by addGiven.  

There is a complication though.  Suppose there are equalities
      instance (Eq a, a~b) => Num (a,b)
Then we normalise the 'givens' wrt the equalities, so the original
given "this" dictionary is cast to one of a different type.  So it's a
bit trickier than before to identify the "special" dictionary whose
superclasses must not be added. See test
   indexed-types/should_run/EqInInstance

We need a persistent property of the dictionary to record this
special-ness.  Current I'm using the InstLocOrigin (a bit of a hack,
but cool), which is maintained by dictionary normalisation.
Specifically, the InstLocOrigin is
	     NoScOrigin
then the no-superclass thing kicks in.  WATCH OUT if you fiddle
with InstLocOrigin!
1291

1292
\begin{code}
1293
tcSimplifySuperClasses
1294
	:: InstLoc 
1295
1296
	-> Inst		-- The dict whose superclasses 
			-- are being figured out
1297
1298
1299
	-> [Inst]	-- Given 
	-> [Inst]	-- Wanted
	-> TcM TcDictBinds
1300
tcSimplifySuperClasses loc this givens sc_wanteds
1301
  = do	{ traceTc (text "tcSimplifySuperClasses")
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313

	      -- Note [Recursive instances and superclases]
        ; no_sc_loc <- getInstLoc NoScOrigin
	; let no_sc_this = setInstLoc this no_sc_loc

	; let env =  RedEnv { red_doc = pprInstLoc loc, 
	     		      red_try_me = try_me,
	     	     	      red_givens = no_sc_this : givens, 
	     	     	      red_stack = (0,[]),
	     	     	      red_improve = False }  -- No unification vars


1314
	; (irreds,binds1) <- checkLoop env sc_wanteds
1315
	; let (tidy_env, tidy_irreds) = tidyInsts irreds
1316
	; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
1317
	; return binds1 }
1318
  where
1319
1320
    try_me _ = ReduceMe  -- Try hard, so we completely solve the superclass 
    	       		 -- constraints right here. See Note [SUPERCLASS-LOOP 1]
1321
1322
1323
\end{code}


1324
1325
1326
1327
1328
1329
%************************************************************************
%*									*
\subsection{tcSimplifyRestricted}
%*									*
%************************************************************************

1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
tcSimplifyRestricted infers which type variables to quantify for a 
group of restricted bindings.  This isn't trivial.

Eg1:	id = \x -> x
	We want to quantify over a to get id :: forall a. a->a
	
Eg2:	eq = (==)
	We do not want to quantify over a, because there's an Eq a 
	constraint, so we get eq :: a->a->Bool	(notice no forall)

So, assume:
	RHS has type 'tau', whose free tyvars are tau_tvs
	RHS has constraints 'wanteds'

Plan A (simple)
  Quantify over (tau_tvs \ ftvs(wanteds))
  This is bad. The constraints may contain (Monad (ST s))
  where we have 	instance Monad (ST s) where...
  so there's no need to be monomorphic in s!

  Also the constraint might be a method constraint,
  whose type mentions a perfectly innocent tyvar:
	  op :: Num a => a -> b -> a
  Here, b is unconstrained.  A good example would be
	foo = op (3::Int)
  We want to infer the polymorphic type
	foo :: forall b. b -> b


Plan B (cunning, used for a long time up to and including GHC 6.2)
  Step 1: Simplify the constraints as much as possible (to deal 
  with Plan A's problem).  Then set
	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )

  Step 2: Now simplify again, treating the constraint as 'free' if 
  it does not mention qtvs, and trying to reduce it otherwise.
  The reasons for this is to maximise sharing.

  This fails for a very subtle reason.  Suppose that in the Step 2
  a constraint (Foo (Succ Zero) (Succ Zero) b) gets thrown upstairs as 'free'.
  In the Step 1 this constraint might have been simplified, perhaps to
  (Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'.
  This won't happen in Step 2... but that in turn might prevent some other
1373
1374
  constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..}) 
  and that in turn breaks the invariant that no constraints are quantified over.
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386

  Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates
  the problem.


Plan C (brutal)
  Step 1: Simplify the constraints as much as possible (to deal 
  with Plan A's problem).  Then set
	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
  Return the bindings from Step 1.
  

1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
A note about Plan C (arising from "bug" reported by George Russel March 2004)
Consider this:

      instance (HasBinary ty IO) => HasCodedValue ty

      foo :: HasCodedValue a => String -> IO a

      doDecodeIO :: HasCodedValue a => () -> () -> IO a
      doDecodeIO codedValue view  
        = let { act = foo "foo" } in  act

You might think this should work becuase the call to foo gives rise to a constraint
(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO.  But the
restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the
constraint using the (rather bogus) instance declaration, and now we are stuffed.
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422

I claim this is not really a bug -- but it bit Sergey as well as George.  So here's
plan D


Plan D (a variant of plan B)
  Step 1: Simplify the constraints as much as possible (to deal 
  with Plan A's problem), BUT DO NO IMPROVEMENT.  Then set
	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )

  Step 2: Now simplify again, treating the constraint as 'free' if 
  it does not mention qtvs, and trying to reduce it otherwise.

  The point here is that it's generally OK to have too few qtvs; that is,
  to make the thing more monomorphic than it could be.  We don't want to
  do that in the common cases, but in wierd cases it's ok: the programmer
  can always add a signature.  

  Too few qtvs => too many wanteds, which is what happens if you do less
  improvement.

1423

1424
1425
\begin{code}
tcSimplifyRestricted 	-- Used for restricted binding groups
1426
			-- i.e. ones subject to the monomorphism restriction
1427
	:: SDoc
1428
1429
	-> TopLevelFlag
	-> [Name]		-- Things bound in this group
1430
	-> TcTyVarSet		-- Free in the type of the RHSs
1431
	-> [Inst]		-- Free in the RHSs
1432
	-> TcM ([TyVar],	-- Tyvars to quantify (zonked and quantified)
1433
		TcDictBinds)	-- Bindings
1434
1435
1436
	-- tcSimpifyRestricted returns no constraints to
	-- quantify over; by definition there are none.
	-- They are all thrown back in the LIE
1437

1438
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
1439
	-- Zonk everything in sight
1440
  = do	{ traceTc (text "tcSimplifyRestricted")
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1441
	; wanteds_z <- zonkInsts wanteds
1442

1443
   	-- 'ReduceMe': Reduce as far as we can.  Don't stop at
1444
1445
1446
1447
	-- 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.
1448
1449
	--
	-- BUT do no improvement!  See Plan D above
1450
1451
	-- HOWEVER, some unification may take place, if we instantiate
	-- 	    a method Inst with an equality constraint
1452
	; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe)