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

Handles @deriving@ clauses on @data@ declarations.

\begin{code}
9
module TcDeriv ( tcDeriving ) where
10

11
#include "HsVersions.h"
12

13
import HsSyn
14
import DynFlags	( DynFlag(..) )
15

16
import Generics		( mkTyConGenericBinds )
17
import TcRnMonad
18
import TcEnv		( newDFunName, pprInstInfoDetails, 
19
			  InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
20
			  tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
21
			)
22
import TcGenDeriv	-- Deriv stuff
23
24
import InstEnv		( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList )
import Inst		( getOverlapFlag )
25
import TcHsType		( tcHsDeriv )
26
import TcSimplify	( tcSimplifyDeriv )
27

28
import RnBinds		( rnMethodBinds, rnTopBinds )
29
import RnEnv		( bindLocalNames )
30
import HscTypes		( FixityEnv )
31

32
import Class		( className, classArity, classKey, classTyVars, classSCTheta, Class )
33
import Type		( zipOpenTvSubst, substTheta )
34
import ErrUtils		( dumpIfSet_dyn )
35
import MkId		( mkDictFunId )
36
import DataCon		( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
37
import Maybes		( catMaybes )
38
import RdrName		( RdrName )
39
import Name		( Name, getSrcLoc )
40
import NameSet		( duDefs )
41
import Kind		( splitKindFunTys )
42
import TyCon		( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
43
			  tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
44
			  isEnumerationTyCon, isRecursiveTyCon, TyCon
45
			)
46
import TcType		( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
47
			  isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
48
49
			  tcEqTypes, tcSplitAppTys, mkAppTys )
import Var		( TyVar, tyVarKind, varName )
50
import VarSet		( mkVarSet, subVarSet )
51
import PrelNames
52
import SrcLoc		( srcLocSpan, Located(..) )
53
import Util		( zipWithEqual, sortLe, notNull )
54
import ListSetOps	( removeDups,  assocMaybe )
55
import Outputable
56
import Bag
57
58
59
60
61
62
63
64
65
66
\end{code}

%************************************************************************
%*									*
\subsection[TcDeriv-intro]{Introduction to how we do deriving}
%*									*
%************************************************************************

Consider

67
68
	data T a b = C1 (Foo a) (Bar b)
		   | C2 Int (T b a)
69
70
71
		   | C3 (T a a)
		   deriving (Eq)

72
73
74
75
[NOTE: See end of these comments for what to do with 
	data (C a, D b) => T a b = ...
]

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
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
125
126
We want to come up with an instance declaration of the form

	instance (Ping a, Pong b, ...) => Eq (T a b) where
		x == y = ...

It is pretty easy, albeit tedious, to fill in the code "...".  The
trick is to figure out what the context for the instance decl is,
namely @Ping@, @Pong@ and friends.

Let's call the context reqd for the T instance of class C at types
(a,b, ...)  C (T a b).  Thus:

	Eq (T a b) = (Ping a, Pong b, ...)

Now we can get a (recursive) equation from the @data@ decl:

	Eq (T a b) = Eq (Foo a) u Eq (Bar b)	-- From C1
		   u Eq (T b a) u Eq Int	-- From C2
		   u Eq (T a a)			-- From C3

Foo and Bar may have explicit instances for @Eq@, in which case we can
just substitute for them.  Alternatively, either or both may have
their @Eq@ instances given by @deriving@ clauses, in which case they
form part of the system of equations.

Now all we need do is simplify and solve the equations, iterating to
find the least fixpoint.  Notice that the order of the arguments can
switch around, as here in the recursive calls to T.

Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.

We start with:

	Eq (T a b) = {}		-- The empty set

Next iteration:
	Eq (T a b) = Eq (Foo a) u Eq (Bar b)	-- From C1
		   u Eq (T b a) u Eq Int	-- From C2
		   u Eq (T a a)			-- From C3

	After simplification:
		   = Eq a u Ping b u {} u {} u {}
		   = Eq a u Ping b

Next iteration:

	Eq (T a b) = Eq (Foo a) u Eq (Bar b)	-- From C1
		   u Eq (T b a) u Eq Int	-- From C2
		   u Eq (T a a)			-- From C3

	After simplification:
127
		   = Eq a u Ping b
128
129
		   u (Eq b u Ping a)
		   u (Eq a u Ping a)
130

131
132
133
134
135
136
137
138
139
140
141
142
143
		   = Eq a u Ping b u Eq b u Ping a

The next iteration gives the same result, so this is the fixpoint.  We
need to make a canonical form of the RHS to ensure convergence.  We do
this by simplifying the RHS to a form in which

	- the classes constrain only tyvars
	- the list is sorted by tyvar (major key) and then class (minor key)
	- no duplicates, of course

So, here are the synonyms for the ``equation'' structures:

\begin{code}
144
145
146
type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
		-- The Name is the name for the DFun we'll build
		-- The tyvars bind all the variables in the RHS
147

148
149
150
pprDerivEqn (n,c,tc,tvs,rhs)
  = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)

151
type DerivRhs  = ThetaType
152
153
154
type DerivSoln = DerivRhs
\end{code}

155

156
157
[Data decl contexts] A note about contexts on data decls
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
Consider

	data (RealFloat a) => Complex a = !a :+ !a deriving( Read )

We will need an instance decl like:

	instance (Read a, RealFloat a) => Read (Complex a) where
	  ...

The RealFloat in the context is because the read method for Complex is bound
to construct a Complex, and doing that requires that the argument type is
in RealFloat. 

But this ain't true for Show, Eq, Ord, etc, since they don't construct
a Complex; they only take them apart.

Our approach: identify the offending classes, and add the data type
context to the instance decl.  The "offending classes" are

	Read, Enum?

179
180
181
182
183
FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
pattern matching against a constructor from a data type with a context
gives rise to the constraints for that context -- or at least the thinned
version.  So now all classes are "offending".

184
185
186
187
188
189
190
191
192
193
194
195
196
197
[Newtype deriving]
~~~~~~~~~~~~~~~~~~
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

Notice the free 'a' in the deriving.  We have to fill this out to 
    newtype T = T Char deriving( forall a. C [a] )

And then translate it to:
    instance C [a] Char => C [a] T where ...
    
	
198

199

200
201
202
203
204
205
206
%************************************************************************
%*									*
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
%*									*
%************************************************************************

\begin{code}
207
tcDeriving  :: [LTyClDecl Name]	-- All type constructors
208
	    -> TcM ([InstInfo],		-- The generated "instance decls"
209
		    [HsBindGroup Name])	-- Extra generated top-level bindings
210

211
tcDeriving tycl_decls
212
  = recoverM (returnM ([], [])) $
213
214
    do	{   	-- Fish the "deriving"-related information out of the TcEnv
		-- and make the necessary "equations".
215
216
	  overlap_flag <- getOverlapFlag
	; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls
217

218
	; (ordinary_inst_info, deriv_binds) 
219
220
		<- extendLocalInstEnv (map iSpec newtype_inst_info)  $
		   deriveOrdinaryStuff overlap_flag ordinary_eqns
221
222
		-- Add the newtype-derived instances to the inst env
		-- before tacking the "ordinary" ones
223

224
	; let inst_info = newtype_inst_info ++ ordinary_inst_info
225
226
227
228
229
230
231
232
233

	-- If we are compiling a hs-boot file, 
	-- don't generate any derived bindings
	; is_boot <- tcIsHsBoot
	; if is_boot then
		return (inst_info, [])
	  else do
	{

234
	-- Generate the generic to/from functions from each type declaration
235
	; gen_binds <- mkGenericBinds tycl_decls
236
237

	-- Rename these extra bindings, discarding warnings about unused bindings etc
238
239
	-- Set -fglasgow exts so that we can have type signatures in patterns,
	-- which is used in the generic binds
240
	; rn_binds
241
		<- discardWarnings $ setOptM Opt_GlasgowExts $ do
242
243
			{ (rn_deriv, _dus1) <- rnTopBinds deriv_binds []
			; (rn_gen, dus_gen) <- rnTopBinds gen_binds   []
244
245
246
			; keepAliveSetTc (duDefs dus_gen)	-- Mark these guys to
								-- be kept alive
			; return (rn_deriv ++ rn_gen) }
247
248


249
250
251
	; dflags <- getDOpts
	; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" 
	  	   (ddump_deriving inst_info rn_binds))
252

253
	; returnM (inst_info, rn_binds)
254
	}}
255
  where
256
    ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc
257
    ddump_deriving inst_infos extra_binds
258
      = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds)
259

260
-----------------------------------------
261
deriveOrdinaryStuff overlap_flag []	-- Short cut
262
  = returnM ([], emptyLHsBinds)
263

264
deriveOrdinaryStuff overlap_flag eqns
265
266
267
  = do	{	-- Take the equation list and solve it, to deliver a list of
		-- solutions, a.k.a. the contexts for the instance decls
		-- required for the corresponding equations.
268
	  inst_specs <- solveDerivEqns overlap_flag eqns
269

270
271
	-- Generate the InstInfo for each dfun, 
	-- plus any auxiliary bindings it needs
272
	; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst inst_specs
273

274
275
	-- Generate any extra not-one-inst-decl-specific binds, 
	-- notably "con2tag" and/or "tag2con" functions.  
276
	; extra_binds <- genTaggeryBinds inst_infos
277
278

	-- Done
279
280
	; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s))
   }
281
282
283

-----------------------------------------
mkGenericBinds tycl_decls
284
285
286
  = do	{ tcs <- mapM tcLookupTyCon 
			[ tc_name | 
			  L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls]
287
		-- We are only interested in the data type declarations
288
289
	; return (unionManyBags [ mkTyConGenericBinds tc | 
				  tc <- tcs, tyConHasGenerics tc ]) }
290
		-- And then only in the ones whose 'has-generics' flag is on
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
\end{code}


%************************************************************************
%*									*
\subsection[TcDeriv-eqns]{Forming the equations}
%*									*
%************************************************************************

@makeDerivEqns@ fishes around to find the info about needed derived
instances.  Complicating factors:
\begin{itemize}
\item
We can only derive @Enum@ if the data type is an enumeration
type (all nullary data constructors).

\item
We can only derive @Ix@ if the data type is an enumeration {\em
or} has just one data constructor (e.g., tuples).
\end{itemize}

[See Appendix~E in the Haskell~1.2 report.] This code here deals w/
all those.

\begin{code}
316
317
makeDerivEqns :: OverlapFlag
	      -> [LTyClDecl Name] 
318
319
	      -> TcM ([DerivEqn],	-- Ordinary derivings
		      [InstInfo])	-- Special newtype derivings
320

321
makeDerivEqns overlap_flag tycl_decls
322
323
  = mapAndUnzipM mk_eqn derive_these	 	`thenM` \ (maybe_ordinaries, maybe_newtypes) ->
    returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
324
325
  where
    ------------------------------------------------------------------
326
    derive_these :: [(NewOrData, Name, LHsType Name)]
327
328
	-- Find the (nd, TyCon, Pred) pairs that must be `derived'
    derive_these = [ (nd, tycon, pred) 
329
		   | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, 
330
			          tcdDerivs = Just preds }) <- tycl_decls,
331
		     pred <- preds ]
332
333

    ------------------------------------------------------------------
334
    mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
335
	-- We swizzle the tyvars and datacons out of the tycon
336
	-- to make the rest of the equation
337
338
339
	--
	-- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign
	-- we allow deriving (forall a. C [a]).
340

341
    mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
342
      = tcLookupTyCon tycon_name		`thenM` \ tycon ->
343
	setSrcSpan (srcLocSpan (getSrcLoc tycon))		$
344
        addErrCtxt (derivCtxt Nothing tycon)	$
345
346
	tcExtendTyVarEnv (tyConTyVars tycon)	$	-- Deriving preds may (now) mention
							-- the type variables for the type constructor
347
348
349
	tcHsDeriv hs_deriv_ty			`thenM` \ (deriv_tvs, clas, tys) ->
	doptM Opt_GlasgowExts			`thenM` \ gla_exts ->
        mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys
350

351
    ------------------------------------------------------------------
352
353
    mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
      | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
354
      = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
355
      | otherwise 
356
357
      = do { eqn <- mkDataTypeEqn tycon clas
	   ; returnM (Just eqn, Nothing) }
358

359
    mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys
360
      | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
361
      =		-- Go ahead and use the isomorphism
362
	   traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)	`thenM_`
363
       	   new_dfun_name clas tycon  		`thenM` \ dfun_name ->
364
	   returnM (Nothing, Just (InstInfo { iSpec  = mk_inst_spec dfun_name,
365
					      iBinds = NewTypeDerived rep_tys }))
366
      | std_class gla_exts clas
367
      = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys	-- Go via bale-out route
368
369
370
371
372
373

      | otherwise 				-- Non-standard instance
      = bale_out (if gla_exts then	
		   	cant_derive_err	-- Too hard
		  else
			non_std_err)	-- Just complain about being a non-std instance
374
375
      where
	-- Here is the plan for newtype derivings.  We see
376
	--	  newtype T a1...an = T (t ak...an) deriving (.., C s1 .. sm, ...)
377
378
379
380
381
	-- where t is a type,
	-- 	 ak...an is a suffix of a1..an
	--	 ak...an do not occur free in t, 
	-- 	 (C s1 ... sm) is a  *partial applications* of class C 
	--			with the last parameter missing
382
383
	--
	-- We generate the instances
384
385
386
	--	 instance C s1 .. sm (t ak...ap) => C s1 .. sm (T a1...ap)
	-- where T a1...ap is the partial application of the LHS of the correct kind
	-- and p >= k
387
388
	--
	-- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
389
390
	--	instance Monad (ST s) => Monad (T s) where 
	--	  fail = coerce ... (fail @ ST s)
391
	-- (Actually we don't need the coerce, because non-rec newtypes are transparent
392

393
394
	clas_tyvars = classTyVars clas
	kind = tyVarKind (last clas_tyvars)
395
396
		-- Kind of the thing we want to instance
		--   e.g. argument kind of Monad, *->*
397

398
	(arg_kinds, _) = splitKindFunTys kind
399
400
401
402
	n_args_to_drop = length arg_kinds	
		-- Want to drop 1 arg from (T s a) and (ST s a)
		-- to get 	instance Monad (ST s) => Monad (T s)

403
	-- Note [newtype representation]
404
405
406
	-- Need newTyConRhs *not* newTyConRep to get the representation 
	-- type, because the latter looks through all intermediate newtypes
	-- For example
407
408
409
410
	--	newtype B = MkB Int
	--	newtype A = MkA B deriving( Num )
	-- We want the Num instance of B, *not* the Num instance of Int,
	-- when making the Num instance of A!
411
        (tc_tvs, rep_ty)      = newTyConRhs tycon
412
	(rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
413
414

	n_tyvars_to_keep = tyConArity tycon  - n_args_to_drop
415
416
	tyvars_to_drop   = drop n_tyvars_to_keep tc_tvs
	tyvars_to_keep   = take n_tyvars_to_keep tc_tvs
417

418
	n_args_to_keep = length rep_ty_args - n_args_to_drop
419
420
	args_to_drop   = drop n_args_to_keep rep_ty_args
 	args_to_keep   = take n_args_to_keep rep_ty_args
421

422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
	rep_tys  = tys ++ [mkAppTys rep_fn args_to_keep]
	rep_pred = mkClassPred clas rep_tys
		-- rep_pred is the representation dictionary, from where
		-- we are gong to get all the methods for the newtype dictionary

	inst_tys = (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)])
		-- The 'tys' here come from the partial application
		-- in the deriving clause. The last arg is the new
		-- instance type.

		-- We must pass the superclasses; the newtype might be an instance
		-- of them in a different way than the representation type
		-- E.g.		newtype Foo a = Foo a deriving( Show, Num, Eq )
		-- Then the Show instance is not done via isomprphism; it shows
		-- 	Foo 3 as "Foo 3"
		-- The Num instance is derived via isomorphism, but the Show superclass
		-- dictionary must the Show instance for Foo, *not* the Show dictionary
		-- gotten from the Num dictionary. So we must build a whole new dictionary
		-- not just use the Num one.  The instance we want is something like:
		--	instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
		--		(+) = ((+)@a)
		--		...etc...
		-- There's no 'corece' needed because after the type checker newtypes
		-- are transparent.

447
	sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys)
448
449
450
451
			      (classSCTheta clas)

		-- If there are no tyvars, there's no need
		-- to abstract over the dictionaries we need
452
453
454
	dict_tvs = deriv_tvs ++ tc_tvs
	dict_args | null dict_tvs = []
		  | otherwise     = rep_pred : sc_theta
455
456

		-- Finally! Here's where we build the dictionary Id
457
458
459
460
	mk_inst_spec dfun_name 
	  = mkLocalInstance dfun overlap_flag
	  where
	    dfun = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys
461
462
463

	-------------------------------------------------------------------
	--  Figuring out whether we can only do this newtype-deriving thing
464

465
	right_arity = length tys + 1 == classArity clas
466

467
468
		-- Never derive Read,Show,Typeable,Data this way 
	non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
469
	can_derive_via_isomorphism
470
	   =  not (getUnique clas `elem` non_iso_classes)
471
	   && right_arity 			-- Well kinded;
472
473
						-- eg not: newtype T ... deriving( ST )
						--	because ST needs *2* type params
474
	   && n_tyvars_to_keep >= 0		-- Type constructor has right kind:
475
						-- eg not: newtype T = T Int deriving( Monad )
476
	   && n_args_to_keep   >= 0		-- Rep type has right kind: 
477
478
						-- eg not: newtype T a = T Int deriving( Monad )
	   && eta_ok				-- Eta reduction works
479
480
481
482
	   && not (isRecursiveTyCon tycon)	-- Does not work for recursive tycons:
						--	newtype A = MkA [A]
						-- Don't want
						--	instance Eq [A] => Eq A !!
483
484
485
486
			-- Here's a recursive newtype that's actually OK
			--	newtype S1 = S1 [T1 ()]
			--	newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
			-- It's currently rejected.  Oh well.
487
488
489
490
			-- In fact we generate an instance decl that has method of form
			--	meth @ instTy = meth @ repTy
			-- (no coerce's).  We'd need a coerce if we wanted to handle
			-- recursive newtypes too
491

492
493
494
495
496
497
	-- Check that eta reduction is OK
	-- 	(a) the dropped-off args are identical
	--	(b) the remaining type args mention 
	--	    only the remaining type variables
	eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
	      && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) 
498
499

	cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
500
				(vcat [ptext SLIT("even with cunning newtype deriving:"),
501
					if isRecursiveTyCon tycon then
502
					  ptext SLIT("the newtype is recursive")
503
504
505
506
507
508
509
510
511
512
513
					else empty,
					if not right_arity then 
					  quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("does not have arity 1")
					else empty,
					if not (n_tyvars_to_keep >= 0) then 
					  ptext SLIT("the type constructor has wrong kind")
					else if not (n_args_to_keep >= 0) then
					  ptext SLIT("the representation type has wrong kind")
					else if not eta_ok then 
					  ptext SLIT("the eta-reduction property does not hold")
					else empty
514
				      ])
515

516
517
518
519
	non_std_err = derivingThingErr clas tys tycon tyvars_to_keep
				(vcat [non_std_why clas,
				       ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")])

520
    bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing) 
521

522
523
524
525
526
527
528
529
530
531
532
std_class gla_exts clas 
  =  key `elem` derivableClassKeys
  || (gla_exts && (key == typeableClassKey || key == dataClassKey))
  where
     key = classKey clas
    
std_class_via_iso clas	-- These standard classes can be derived for a newtype
			-- using the isomorphism trick *even if no -fglasgow-exts*
  = classKey clas `elem`  [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
	-- Not Read/Show because they respect the type
	-- Not Enum, becuase newtypes are never in Enum
533

534

535
536
537
538
new_dfun_name clas tycon 	-- Just a simple wrapper
  = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
	-- The type passed to newDFunName is only used to generate
	-- a suitable string; hence the empty type arg list
539

540
541
542
543
544
545
546
547
------------------------------------------------------------------
mkDataTypeEqn :: TyCon -> Class -> TcM DerivEqn
mkDataTypeEqn tycon clas
  | clas `hasKey` typeableClassKey
  =	-- The Typeable class is special in several ways
	-- 	  data T a b = ... deriving( Typeable )
	-- gives
	--	  instance Typeable2 T where ...
548
	-- Notice that:
549
550
	-- 1. There are no constraints in the instance
	-- 2. There are no type variables either
551
	-- 3. The actual class we want to generate isn't necessarily
552
553
554
555
556
557
558
559
560
561
562
	--	Typeable; it depends on the arity of the type
    do	{ real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
	; dfun_name <- new_dfun_name real_clas tycon
  	; return (dfun_name, real_clas, tycon, [], []) }

  | otherwise
  = do	{ dfun_name <- new_dfun_name clas tycon
  	; return (dfun_name, clas, tycon, tyvars, constraints) }
  where
    tyvars            = tyConTyVars tycon
    constraints       = extra_constraints ++ ordinary_constraints
563
    extra_constraints = tyConStupidTheta tycon
564
565
566
567
568
569
570
571
572
573
	 -- "extra_constraints": see note [Data decl contexts] above

    ordinary_constraints
      = [ mkClassPred clas [arg_ty] 
        | data_con <- tyConDataCons tycon,
          arg_ty   <- dataConOrigArgTys data_con,
          not (isUnLiftedType arg_ty)	-- No constraints for unlifted types?
        ]


574
575
576
577
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism

578
579
580
checkSideConditions :: Bool -> TyCon -> [TyVar] -> Class -> [TcType] -> Maybe SDoc
checkSideConditions gla_exts tycon deriv_tvs clas tys
  | notNull deriv_tvs || notNull tys	
581
582
583
584
585
586
587
  = Just ty_args_why	-- e.g. deriving( Foo s )
  | otherwise
  = case [cond | (key,cond) <- sideConditions, key == getUnique clas] of
	[]     -> Just (non_std_why clas)
	[cond] -> cond (gla_exts, tycon)
	other  -> pprPanic "checkSideConditions" (ppr clas)
  where
588
    ty_args_why	= quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("is not a class")
589
590
591
592
593
594
595
596
597
598
599
600

non_std_why clas = quotes (ppr clas) <+> ptext SLIT("is not a derivable class")

sideConditions :: [(Unique, Condition)]
sideConditions
  = [	(eqClassKey, 	   cond_std),
	(ordClassKey,	   cond_std),
	(readClassKey,	   cond_std),
	(showClassKey,	   cond_std),
	(enumClassKey,	   cond_std `andCond` cond_isEnumeration),
	(ixClassKey,	   cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
	(boundedClassKey,  cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
601
 	(typeableClassKey, cond_glaExts `andCond` cond_typeableOK),
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
	(dataClassKey,	   cond_glaExts `andCond` cond_std)
    ]

type Condition = (Bool, TyCon) -> Maybe SDoc	-- Nothing => OK

orCond :: Condition -> Condition -> Condition
orCond c1 c2 tc 
  = case c1 tc of
	Nothing -> Nothing		-- c1 succeeds
	Just x  -> case c2 tc of	-- c1 fails
		     Nothing -> Nothing
		     Just y  -> Just (x $$ ptext SLIT("  and") $$ y)
					-- Both fail

andCond c1 c2 tc = case c1 tc of
		     Nothing -> c2 tc	-- c1 succeeds
		     Just x  -> Just x	-- c1 fails

cond_std :: Condition
cond_std (gla_exts, tycon)
622
623
624
  | any (not . isVanillaDataCon) data_cons = Just existential_why     
  | null data_cons		    	   = Just no_cons_why
  | otherwise      			   = Nothing
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
  where
    data_cons       = tyConDataCons tycon
    no_cons_why	    = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
    existential_why = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)")
  
cond_isEnumeration :: Condition
cond_isEnumeration (gla_exts, tycon)
  | isEnumerationTyCon tycon = Nothing
  | otherwise		     = Just why
  where
    why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")

cond_isProduct :: Condition
cond_isProduct (gla_exts, tycon)
  | isProductTyCon tycon = Nothing
  | otherwise	         = Just why
  where
    why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")

644
645
646
647
648
649
650
651
cond_typeableOK :: Condition
-- OK for Typeable class
-- Currently: (a) args all of kind *
--	      (b) 7 or fewer args
cond_typeableOK (gla_exts, tycon)
  | tyConArity tycon > 7				      = Just too_many
  | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
  | otherwise	  				              = Nothing
652
  where
653
654
    too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
    bad_kind = quotes (ppr tycon) <+> ptext SLIT("has arguments of kind other than `*'")
655
656
657
658
659
660

cond_glaExts :: Condition
cond_glaExts (gla_exts, tycon) | gla_exts  = Nothing
			       | otherwise = Just why
  where
    why  = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
661
662
663
664
665
666
667
668
\end{code}

%************************************************************************
%*									*
\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
%*									*
%************************************************************************

669
A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
670
671
672
673
terms, which is the final correct RHS for the corresponding original
equation.
\begin{itemize}
\item
674
Each (k,TyVarTy tv) in a solution constrains only a type
675
676
677
variable, tv.

\item
678
The (k,TyVarTy tv) pairs in a solution are canonically
679
680
681
682
683
ordered by sorting on type varible, tv, (major key) and then class, k,
(minor key)
\end{itemize}

\begin{code}
684
685
686
solveDerivEqns :: OverlapFlag
	       -> [DerivEqn]
	       -> TcM [Instance]-- Solns in same order as eqns.
687
				-- This bunch is Absolutely minimal...
688

689
solveDerivEqns overlap_flag orig_eqns
690
  = iterateDeriv 1 initial_solutions
691
692
693
694
695
696
697
  where
	-- The initial solutions for the equations claim that each
	-- instance has an empty context; this solution is certainly
	-- in canonical form.
    initial_solutions :: [DerivSoln]
    initial_solutions = [ [] | _ <- orig_eqns ]

698
    ------------------------------------------------------------------
699
700
701
	-- iterateDeriv calculates the next batch of solutions,
	-- compares it with the current one; finishes if they are the
	-- same, otherwise recurses with the new solutions.
702
	-- It fails if any iteration fails
703
    iterateDeriv :: Int -> [DerivSoln] -> TcM [Instance]
704
705
706
707
708
709
710
    iterateDeriv n current_solns
      | n > 20 	-- Looks as if we are in an infinite loop
		-- This can happen if we have -fallow-undecidable-instances
		-- (See TcSimplify.tcSimplifyDeriv.)
      = pprPanic "solveDerivEqns: probable loop" 
		 (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
      | otherwise
711
      =	let 
712
713
	    inst_specs = zipWithEqual "add_solns" mk_inst_spec 
				      orig_eqns current_solns
714
        in
715
        checkNoErrs (
716
717
		  -- Extend the inst info from the explicit instance decls
		  -- with the current set of solutions, and simplify each RHS
718
	    extendLocalInstEnv inst_specs $
719
720
	    mappM gen_soln orig_eqns
	)				`thenM` \ new_solns ->
721
	if (current_solns == new_solns) then
722
	    returnM inst_specs
723
	else
724
	    iterateDeriv (n+1) new_solns
725
726

    ------------------------------------------------------------------
727
    gen_soln (_, clas, tc,tyvars,deriv_rhs)
728
      = setSrcSpan (srcLocSpan (getSrcLoc tc))		$
729
730
	addErrCtxt (derivCtxt (Just clas) tc)	$
	tcSimplifyDeriv tyvars deriv_rhs	`thenM` \ theta ->
731
	returnM (sortLe (<=) theta)	-- Canonicalise before returning the soluction
732

733
734
735
736
737
738
739
740
741
    ------------------------------------------------------------------
    mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
	= mkLocalInstance dfun overlap_flag
	where
	  dfun = mkDictFunId dfun_name tyvars theta clas
			     [mkTyConApp tycon (mkTyVarTys tyvars)]

extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
-- Add new locally-defined instances; don't bother to check
742
743
744
-- for functional dependency errors -- that'll happen in TcInstDcls
extendLocalInstEnv dfuns thing_inside
 = do { env <- getGblEnv
745
      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns 
746
747
	     env'      = env { tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
\end{code}

%************************************************************************
%*									*
\subsection[TcDeriv-normal-binds]{Bindings for the various classes}
%*									*
%************************************************************************

After all the trouble to figure out the required context for the
derived instance declarations, all that's left is to chug along to
produce them.  They will then be shoved into @tcInstDecls2@, which
will do all its usual business.

There are lots of possibilities for code to generate.  Here are
various general remarks.

PRINCIPLES:
\begin{itemize}
\item
We want derived instances of @Eq@ and @Ord@ (both v common) to be
``you-couldn't-do-better-by-hand'' efficient.

\item
771
Deriving @Show@---also pretty common--- should also be reasonable good code.
772
773
774
775
776
777
778
779
780

\item
Deriving for the other classes isn't that common or that big a deal.
\end{itemize}

PRAGMATICS:

\begin{itemize}
\item
781
Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
782
783

\item
784
Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
785
786

\item
787
We {\em normally} generate code only for the non-defaulted methods;
788
789
790
791
792
793
794
795
796
797
798
there are some exceptions for @Eq@ and (especially) @Ord@...

\item
Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
constructor's numeric (@Int#@) tag.  These are generated by
@gen_tag_n_con_binds@, and the heuristic for deciding if one of
these is around is given by @hasCon2TagFun@.

The examples under the different sections below will make this
clearer.

799
800
801
802
\item
Much less often (really just for deriving @Ix@), we use a
@_tag2con_<tycon>@ function.  See the examples.

803
\item
804
We use the renamer!!!  Reason: we're supposed to be
805
producing @LHsBinds Name@ for the methods, but that means
806
807
producing correctly-uniquified code on the fly.  This is entirely
possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
808
So, instead, we produce @MonoBinds RdrName@ then heave 'em through
809
810
811
812
the renamer.  What a great hack!
\end{itemize}

\begin{code}
813
814
-- Generate the InstInfo for the required instance,
-- plus any auxiliary bindings required
815
816
817
818
819
820
821
822
823
genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName)
genInst spec
  = do	{ fix_env <- getFixityEnv
	; let
	    (tyvars,_,clas,[ty])    = instanceHead spec
	    clas_nm		    = className clas
	    tycon  	      	    = tcTyConAppTyCon ty 
	    (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon

824
825
	-- Bring the right type variables into 
	-- scope, and rename the method binds
826
827
828
829
	-- It's a bit yukky that we return *renamed* InstInfo, but
	-- *non-renamed* auxiliary bindings
	; (rn_meth_binds, _fvs) <- discardWarnings $ 
				   bindLocalNames (map varName tyvars)	$
830
			 	   rnMethodBinds clas_nm [] meth_binds
831
832

	-- Build the InstInfo
833
834
835
836
	; return (InstInfo { iSpec = spec, 
		  	     iBinds = VanillaInst rn_meth_binds [] }, 
		  aux_binds)
	}
837

838
839
genDerivBinds clas fix_env tycon
  | className clas `elem` typeableClassNames
840
  = (gen_Typeable_binds tycon, emptyLHsBinds)
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860

  | otherwise
  = case assocMaybe gen_list (getUnique clas) of
	Just gen_fn -> gen_fn fix_env tycon
	Nothing	    -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
  where
    gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))]
    gen_list = [(eqClassKey,      no_aux_binds (ignore_fix_env gen_Eq_binds))
 	       ,(ordClassKey,     no_aux_binds (ignore_fix_env gen_Ord_binds))
 	       ,(enumClassKey,    no_aux_binds (ignore_fix_env gen_Enum_binds))
 	       ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds))
 	       ,(ixClassKey,      no_aux_binds (ignore_fix_env gen_Ix_binds))
	       ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds))
 	       ,(showClassKey,    no_aux_binds gen_Show_binds)
 	       ,(readClassKey,    no_aux_binds gen_Read_binds)
	       ,(dataClassKey,    gen_Data_binds)
 	       ]

      -- no_aux_binds is used for generators that don't 
      -- need to produce any auxiliary bindings
861
    no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds)
862
    ignore_fix_env f fix_env tc = f tc
863
864
\end{code}

865

866
867
%************************************************************************
%*									*
868
\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
869
870
871
%*									*
%************************************************************************

872

873
874
875
data Foo ... = ...

con2tag_Foo :: Foo ... -> Int#
876
tag2con_Foo :: Int -> Foo ...	-- easier if Int, not Int#
877
maxtag_Foo  :: Int		-- ditto (NB: not unlifted)
878
879
880
881
882
883
884
885
886
887
888
889


We have a @con2tag@ function for a tycon if:
\begin{itemize}
\item
We're deriving @Eq@ and the tycon has nullary data constructors.

\item
Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
(enum type only????)
\end{itemize}

890
891
892
893
894
895
896
897
We have a @tag2con@ function for a tycon if:
\begin{itemize}
\item
We're deriving @Enum@, or @Ix@ (enum type only???)
\end{itemize}

If we have a @tag2con@ function, we also generate a @maxtag@ constant.

898
\begin{code}
899
900
genTaggeryBinds :: [InstInfo] -> TcM (LHsBinds RdrName)
genTaggeryBinds infos
901
902
  = do	{ names_so_far <- foldlM do_con2tag []           tycons_of_interest
	; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest
903
	; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) }
904
  where
905
906
907
    all_CTs = [ (cls, tcTyConAppTyCon ty)
	      | info <- infos, 
		let (cls,ty) = simpleInstInfoClsTy info ]
908
    all_tycons		    = map snd all_CTs
909
    (tycons_of_interest, _) = removeDups compare all_tycons
910
    
911
    do_con2tag acc_Names tycon
sof's avatar
sof committed
912
      | isDataTyCon tycon &&
sof's avatar
sof committed
913
        ((we_are_deriving eqClassKey tycon
914
	    && any isNullarySrcDataCon (tyConDataCons tycon))
sof's avatar
sof committed
915
	 || (we_are_deriving ordClassKey  tycon
916
	    && not (isProductTyCon tycon))
sof's avatar
sof committed
917
	 || (we_are_deriving enumClassKey tycon)
sof's avatar
sof committed
918
	 || (we_are_deriving ixClassKey   tycon))
sof's avatar
sof committed
919
	
920
      = returnM ((con2tag_RDR tycon, tycon, GenCon2Tag)
921
		   : acc_Names)
sof's avatar
sof committed
922
      | otherwise
923
      = returnM acc_Names
924

925
    do_tag2con acc_Names tycon
sof's avatar
sof committed
926
927
      | isDataTyCon tycon &&
         (we_are_deriving enumClassKey tycon ||
928
929
	  we_are_deriving ixClassKey   tycon
	  && isEnumerationTyCon tycon)
930
      = returnM ( (tag2con_RDR tycon, tycon, GenTag2Con)
931
		 : (maxtag_RDR  tycon, tycon, GenMaxTag)
sof's avatar
sof committed
932
933
		 : acc_Names)
      | otherwise
934
      = returnM acc_Names
935
936

    we_are_deriving clas_key tycon
937
      = is_in_eqns clas_key tycon all_CTs
938
939
      where
	is_in_eqns clas_key tycon [] = False
940
	is_in_eqns clas_key tycon ((c,t):cts)
941
	  =  (clas_key == classKey c && tycon == t)
942
	  || is_in_eqns clas_key tycon cts
943
\end{code}
944

945
\begin{code}
946
947
derivingThingErr clas tys tycon tyvars why
  = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
948
	 parens why]
949
950
  where
    pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
951

952
953
954
955
956
957
958
derivCtxt :: Maybe Class -> TyCon -> SDoc
derivCtxt maybe_cls tycon
  = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
  where
    cls = case maybe_cls of
	    Nothing -> ptext SLIT("instances")
	    Just c  -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
959
\end{code}
960