TcDeriv.lhs 57 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
8
%

Handles @deriving@ clauses on @data@ declarations.

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

11
#include "HsVersions.h"
12

13
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
14
import DynFlags
15

Simon Marlow's avatar
Simon Marlow committed
16
import Generics
17
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
18
import TcEnv
19
20
import TcClassDcl( tcAddDeclCtxt )	-- Small helper
import TcGenDeriv			-- Deriv stuff
Simon Marlow's avatar
Simon Marlow committed
21
22
23
import InstEnv
import Inst
import TcHsType
24
import TcMType
Simon Marlow's avatar
Simon Marlow committed
25
26
27
28
29
30
31
32
import TcSimplify

import RnBinds
import RnEnv
import HscTypes

import Class
import Type
33
import Coercion
Simon Marlow's avatar
Simon Marlow committed
34
35
36
37
38
39
40
41
42
43
44
import ErrUtils
import MkId
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
import VarSet
45
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
46
47
48
import SrcLoc
import Util
import ListSetOps
49
import Outputable
50
import FastString
51
import Bag
52
53

import Control.Monad
54
55
56
57
\end{code}

%************************************************************************
%*									*
58
		Overview
59
60
61
%*									*
%************************************************************************

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Overall plan
~~~~~~~~~~~~
1.  Convert the decls (i.e. data/newtype deriving clauses, 
    plus standalone deriving) to [EarlyDerivSpec]

2.  Infer the missing contexts for the Left DerivSpecs

3.  Add the derived bindings, generating InstInfos

\begin{code}
-- DerivSpec is purely  local to this module
data DerivSpec  = DS { ds_loc     :: SrcSpan 
		     , ds_orig    :: InstOrigin 
		     , ds_name    :: Name
		     , ds_tvs     :: [TyVar] 
		     , ds_theta   :: ThetaType
		     , ds_cls     :: Class
		     , ds_tys     :: [Type]
80
		     , ds_tc      :: TyCon
81
		     , ds_tc_args :: [Type]
82
83
84
85
86
		     , ds_newtype :: Bool }
	-- This spec implies a dfun declaration of the form
	--	 df :: forall tvs. theta => C tys
	-- The Name is the name for the DFun we'll build
	-- The tyvars bind all the variables in the theta
87
88
	-- For family indexes, the tycon in 
	--	 in ds_tys is the *family* tycon
89
	--	 in ds_tc, ds_tc_args is the *representation* tycon
90
	-- For non-family tycons, both are the same
91
92
93
94

	-- ds_newtype = True  <=> Newtype deriving
	--		False <=> Vanilla deriving

95
96
97
98
type DerivContext = Maybe ThetaType
   -- Nothing 	 <=> Vanilla deriving; infer the context of the instance decl
   -- Just theta <=> Standalone deriving: context supplied by programmer

99
100
type EarlyDerivSpec = Either DerivSpec DerivSpec
	-- Left  ds => the context for the instance should be inferred
101
102
103
104
105
106
107
	--	       In this case ds_theta is the list of all the 
	--		  constraints needed, such as (Eq [a], Eq a)
	--		  The inference process is to reduce this to a 
	--		  simpler form (e.g. Eq a)
	-- 
	-- Right ds => the exact context for the instance is supplied 
	--	       by the programmer; it is ds_theta
108
109
110
111
112
113
114
115
116
117
118

pprDerivSpec :: DerivSpec -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 
		   ds_cls = c, ds_tys = tys, ds_theta = rhs })
  = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
	    <+> equals <+> ppr rhs)
\end{code}


Inferring missing contexts 
~~~~~~~~~~~~~~~~~~~~~~~~~~
119
120
Consider

121
122
	data T a b = C1 (Foo a) (Bar b)
		   | C2 Int (T b a)
123
124
125
		   | C3 (T a a)
		   deriving (Eq)

126
127
128
129
[NOTE: See end of these comments for what to do with 
	data (C a, D b) => T a b = ...
]

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
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:
181
		   = Eq a u Ping b
182
183
		   u (Eq b u Ping a)
		   u (Eq a u Ping a)
184

185
186
187
188
189
190
191
192
193
194
195
196
		   = 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:

197

198
199
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
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?

221
222
223
224
225
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".

226
227
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
228
229
230
231
232
233
234
235
236
237
238
239
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 ...
    
	
240
241
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
242
243
244
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
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 isomorphism; 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 may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


264
265
266
267
268
269
Note [Unused constructors and deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #3221.  Consider
   data T = T1 | T2 deriving( Show )
Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
both of them.  So we gather defs/uses from deriving just like anything else.
270

271
272
273
274
275
276
277
%************************************************************************
%*									*
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
%*									*
%************************************************************************

\begin{code}
278
279
tcDeriving  :: [LTyClDecl Name]  -- All type constructors
            -> [LInstDecl Name]  -- All instance declarations
280
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
281
	    -> TcM ([InstInfo Name],	-- The generated "instance decls"
282
283
		    HsValBinds Name,	-- Extra generated top-level bindings
                    DefUses)
284

285
tcDeriving tycl_decls inst_decls deriv_decls
286
  = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
287
    do	{   	-- Fish the "deriving"-related information out of the TcEnv
288
		-- And make the necessary "equations".
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
289
290
291
	  is_boot <- tcIsHsBoot
	; traceTc (text "tcDeriving" <+> ppr is_boot)
	; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
292

293
294
	; overlap_flag <- getOverlapFlag
	; let (infer_specs, given_specs) = splitEithers early_specs
295
	; insts1 <- mapM (genInst True overlap_flag) given_specs
296

297
	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
298
			 inferInstanceContexts overlap_flag infer_specs
299

300
	; insts2 <- mapM (genInst False overlap_flag) final_specs
301

302
		 -- Generate the generic to/from functions from each type declaration
303
	; gen_binds <- mkGenericBinds is_boot tycl_decls
304
	; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
305

306
	; dflags <- getDOpts
twanvl's avatar
twanvl committed
307
308
	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
	         (ddump_deriving inst_info rn_binds))
309

310
	; return (inst_info, rn_binds, rn_dus) }
311
  where
312
    ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
313
    ddump_deriving inst_infos extra_binds
314
      = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
315

316
317
renameDeriv :: Bool -> LHsBinds RdrName
	    -> [(InstInfo RdrName, DerivAuxBinds)]
318
 	    -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
319
320
321
322
renameDeriv is_boot gen_binds insts
  | is_boot	-- If we are compiling a hs-boot file, don't generate any derived bindings
		-- The inst-info bindings will all be empty, but it's easier to
		-- just use rn_inst_info to change the type appropriately
323
324
  = do	{ (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos	
	; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
325

326
  | otherwise
327
  = discardWarnings $ 	 -- Discard warnings about unused bindings etc
328
329
    do	{ (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $  -- Type signatures in patterns 
								  -- are used in the generic binds
330
331
332
333
			       rnTopBinds (ValBindsIn gen_binds [])
	; keepAliveSetTc (duDefs dus_gen)	-- Mark these guys to be kept alive

		-- Generate and rename any extra not-one-inst-decl-specific binds, 
334
		-- notably "con2tag" and/or "tag2con" functions.  
335
336
337
338
339
		-- Bring those names into scope before renaming the instances themselves
	; loc <- getSrcSpanM	-- Generic loc for shared bindings
	; let aux_binds = listToBag $ map (genAuxBind loc) $ 
			  rm_dups [] $ concat deriv_aux_binds
	; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds [])
340
	; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs)
341
342

	; bindLocalNames aux_names $ 
343
344
345
346
    do	{ (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
	; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
	; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
                  dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
347

348
  where
349
350
    (inst_infos, deriv_aux_binds) = unzip insts
    
351
352
353
354
	-- Remove duplicate requests for auxilliary bindings
    rm_dups acc [] = acc
    rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
    		       | otherwise	      = rm_dups (b:acc) bs
355

356

357
    rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
358
	= return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
359

360
    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
361
362
363
364
	= 	-- Bring the right type variables into 
		-- scope (yuk), and rename the method binds
	   ASSERT( null sigs )
	   bindLocalNames (map Var.varName tyvars) $
365
 	   do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
366
367
	      ; let binds' = VanillaInst rn_binds [] standalone_deriv
	      ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
368
	where
369
370
	  (tyvars,_, clas,_) = instanceHead inst
	  clas_nm            = className clas
371

372
-----------------------------------------
373
374
mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
mkGenericBinds is_boot tycl_decls
375
376
377
  | is_boot 
  = return emptyBag
  | otherwise
378
379
380
381
  = do	{ tcs <- mapM tcLookupTyCon [ tcdName d 
    	      	      		    | L _ d <- tycl_decls, isDataDecl d ]
	; return (unionManyBags [ mkTyConGenericBinds tc
				| tc <- tcs, tyConHasGenerics tc ]) }
382
383
384
		-- We are only interested in the data type declarations,
		-- and then only in the ones whose 'has-generics' flag is on
		-- The predicate tyConHasGenerics finds both of these
385
386
387
388
389
\end{code}


%************************************************************************
%*									*
390
		From HsSyn to DerivSpec
391
392
393
%*									*
%************************************************************************

394
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
395
396

\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
397
398
makeDerivSpecs :: Bool 
	       -> [LTyClDecl Name] 
399
400
401
               -> [LInstDecl Name]
	       -> [LDerivDecl Name] 
	       -> TcM [EarlyDerivSpec]
402

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
403
404
405
406
407
408
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
  | is_boot 	-- No 'deriving' at all in hs-boot files
  = do	{ mapM_ add_deriv_err deriv_locs 
	; return [] }
  | otherwise
  = do	{ eqns1 <- mapAndRecoverM deriveTyData all_tydata
409
	; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
410
	; return (eqns1 ++ eqns2) }
411
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
    extractTyDataPreds decls
      = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]

    all_tydata :: [(LHsType Name, LTyClDecl Name)]
	-- Derived predicate paired with its data type declaration
    all_tydata = extractTyDataPreds tycl_decls ++
		 [ pd                -- Traverse assoc data families
                 | L _ (InstDecl _ _ _ ats) <- inst_decls
		 , pd <- extractTyDataPreds ats ]

    deriv_locs = map (getLoc . snd) all_tydata
		 ++ map getLoc deriv_decls

    add_deriv_err loc = setSrcSpan loc $
			addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
				   2 (ptext (sLit "Use an instance declaration instead")))
428
429

------------------------------------------------------------------
430
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
431
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
432
--  e.g.   deriving instance Show a => Show (T a)
433
434
435
436
-- Rather like tcLocalInstDecl
deriveStandalone (L loc (DerivDecl deriv_ty))
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
437
438
439
440
441
442
    do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
       ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
       ; traceTc (text "standalone deriving;"
              <+> text "tvs:" <+> ppr tvs
              <+> text "theta:" <+> ppr theta
              <+> text "tau:" <+> ppr tau)
443
       ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau
444
445
		-- C.f. TcInstDcls.tcLocalInstDecl1

446
447
448
449
450
451
452
453
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
       ; traceTc (text "standalone deriving;"
              <+> text "class:" <+> ppr cls
              <+> text "class types:" <+> ppr cls_tys
              <+> text "type:" <+> ppr inst_ty)
       ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
                   (Just theta) }
454
455

------------------------------------------------------------------
456
deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
457
458
459
460
461
deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, 
					           tcdTyVars = tv_names, 
				    	           tcdTyPats = ty_pats }))
  = setSrcSpan loc     $	-- Use the location of the 'deriving' item
    tcAddDeclCtxt decl $
462
    do	{ (tvs, tc, tc_args) <- get_lhs ty_pats
463
464
	; tcExtendTyVarEnv tvs $	-- Deriving preds may (now) mention
					-- the type variables for the type constructor
465

466
467
468
    do	{ (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
		-- The "deriv_pred" is a LHsType to take account of the fact that for
		-- newtype deriving we allow deriving (forall a. C [a]).
469
470
471
472
473
474
475
476

	-- Given data T a b c = ... deriving( C d ),
	-- we want to drop type variables from T so that (C d (T a)) is well-kinded
	; let cls_tyvars = classTyVars cls
	      kind = tyVarKind (last cls_tyvars)
	      (arg_kinds, _) = splitKindFunTys kind
	      n_args_to_drop = length arg_kinds	
	      n_args_to_keep = tyConArity tc - n_args_to_drop
477
478
479
480
481
482
483
	      args_to_drop   = drop n_args_to_keep tc_args
	      inst_ty        = mkTyConApp tc (take n_args_to_keep tc_args)
	      inst_ty_kind   = typeKind inst_ty
	      dropped_tvs    = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
	      univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
					`minusVarSet` dropped_tvs
 
484
485
486
487
	-- Check that the result really is well-kinded
	; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
		  (derivingKindErr tc cls cls_tys kind)

488
489
490
491
492
493
494
495
496
497
	; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && 		 -- (a)
	           tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
		  (derivingEtaErr cls cls_tys inst_ty)
		-- Check that 
		--  (a) The data type can be eta-reduced; eg reject:
		--		data instance T a a = ... deriving( Monad )
		--  (b) The type class args do not mention any of the dropped type
		--      variables 
		--		newtype T a s = ... deriving( ST s )

498
	-- Type families can't be partially applied
499
500
	-- e.g.   newtype instance T Int a = MkT [a] deriving( Monad )
	-- Note [Deriving, type families, and partial applications]
501
502
503
	; checkTc (not (isOpenTyCon tc) || n_args_to_drop == 0)
		  (typeFamilyPapErr tc cls cls_tys inst_ty)

504
	; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
  where
	-- Tiresomely we must figure out the "lhs", which is awkward for type families
	-- E.g.   data T a b = .. deriving( Eq )
	-- 	    Here, the lhs is (T a b)
	--	  data instance TF Int b = ... deriving( Eq )
	--	    Here, the lhs is (TF Int b)
	-- But if we just look up the tycon_name, we get is the *family*
	-- tycon, but not pattern types -- they are in the *rep* tycon.
    get_lhs Nothing     = do { tc <- tcLookupTyCon tycon_name
			     ; let tvs = tyConTyVars tc
			     ; return (tvs, tc, mkTyVarTys tvs) }
    get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
			     ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
			     ; let (tc, tc_args) = tcSplitTyConApp tc_app
			     ; return (tvs, tc, tc_args) }
520
521

deriveTyData _other
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
522
  = panic "derivTyData"	-- Caller ensures that only TyData can happen
523
\end{code}
524

525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
Note [Deriving, type families, and partial applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When there are no type families, it's quite easy:

    newtype S a = MkS [a]
    -- :CoS :: S  ~ []	-- Eta-reduced

    instance Eq [a] => Eq (S a) 	-- by coercion sym (Eq (coMkS a)) : Eq [a] ~ Eq (S a)
    instance Monad [] => Monad S	-- by coercion sym (Monad coMkS)  : Monad [] ~ Monad S 

When type familes are involved it's trickier:

    data family T a b
    newtype instance T Int a = MkT [a] deriving( Eq, Monad )
    -- :RT is the representation type for (T Int a)
    --  :CoF:R1T a :: T Int a ~ :RT a	-- Not eta reduced
    --  :Co:R1T    :: :RT ~ []		-- Eta-reduced

    instance Eq [a] => Eq (T Int a) 	-- easy by coercion
    instance Monad [] => Monad (T Int)	-- only if we can eta reduce???

The "???" bit is that we don't build the :CoF thing in eta-reduced form
Henc the current typeFamilyPapErr, even though the instance makes sense.
After all, we can write it out
    instance Monad [] => Monad (T Int)	-- only if we can eta reduce???
      return x = MkT [x]
      ... etc ...	

\begin{code}
554
mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
555
          -> DerivContext	-- Just    => context supplied (standalone deriving)
556
				-- Nothing => context inferred (deriving on data decl)
557
558
559
560
561
562
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
--	forall tvs. theta => cls (tys ++ [ty])
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

563
mkEqnHelp orig tvs cls cls_tys tc_app mtheta
564
  | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
565
566
567
568
569
  , isAlgTyCon tycon	-- Check for functions, primitive types etc
  = do	{ (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
	          -- Be careful to test rep_tc here: in the case of families, 
	          -- we want to check the instance tycon, not the family tycon

570
	-- For standalone deriving (mtheta /= Nothing), 
571
572
573
	-- check that all the data constructors are in scope.
	-- No need for this when deriving Typeable, becuase we don't need
	-- the constructors for that.
574
575
576
	; rdr_env <- getGlobalRdrEnv
	; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc)
	      not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
577
578
579
	; checkTc (isNothing mtheta || 
	  	   not hidden_data_cons ||
		   className cls `elem` typeableClassNames) 
580
		  (derivingHiddenErr tycon)
581

582
	; dflags <- getDOpts
583
	; if isDataTyCon rep_tc then
584
		mkDataTypeEqn orig dflags tvs cls cls_tys
585
			      tycon tc_args rep_tc rep_tc_args mtheta
586
	  else
587
		mkNewTypeEqn orig dflags tvs cls cls_tys 
588
			     tycon tc_args rep_tc rep_tc_args mtheta }
589
  | otherwise
590
  = failWithTc (derivingThingErr False cls cls_tys tc_app
591
	       (ptext (sLit "The last argument of the instance must be a data or newtype application")))
592
593
\end{code}

594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
Note [Looking up family instances for deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcLookupFamInstExact is an auxiliary lookup wrapper which requires
that looked-up family instances exist.  If called with a vanilla
tycon, the old type application is simply returned.

If we have
  data instance F () = ... deriving Eq
  data instance F () = ... deriving Eq
then tcLookupFamInstExact will be confused by the two matches;
but that can't happen because tcInstDecls1 doesn't call tcDeriving
if there are any overlaps.

There are two other things that might go wrong with the lookup.
First, we might see a standalone deriving clause
	deriving Eq (F ())
when there is no data instance F () in scope. 

Note that it's OK to have
  data instance F [a] = ...
  deriving Eq (F [(a,b)])
where the match is not exact; the same holds for ordinary data types
with standalone deriving declrations.
617
618
619
620

\begin{code}
tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
tcLookupFamInstExact tycon tys
621
622
623
624
625
  | not (isOpenTyCon tycon)
  = return (tycon, tys)
  | otherwise
  = do { maybeFamInst <- tcLookupFamInst tycon tys
       ; case maybeFamInst of
626
627
           Nothing      -> famInstNotFound tycon tys
           Just famInst -> return famInst
628
       }
629
630
631
632

famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys 
  = failWithTc (ptext (sLit "No family instance for")
633
			<+> quotes (pprTypeApp tycon tys))
634
635
\end{code}

636
637
638
639
640
641
642
643

%************************************************************************
%*									*
		Deriving data types
%*									*
%************************************************************************

\begin{code}
644
645
646
647
648
mkDataTypeEqn :: InstOrigin
              -> DynFlags
              -> [Var]                  -- Universally quantified type variables in the instance
              -> Class                  -- Class for which we need to derive an instance
              -> [Type]                 -- Other parameters to the class except the last
649
650
              -> TyCon                  -- Type constructor for which the instance is requested 
					--    (last parameter to the type class)
651
652
653
              -> [Type]                 -- Parameters to the type constructor
              -> TyCon                  -- rep of the above (for type families)
              -> [Type]                 -- rep of the above
654
              -> DerivContext        -- Context of the instance, for standalone deriving
655
656
657
              -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error

mkDataTypeEqn orig dflags tvs cls cls_tys
658
              tycon tc_args rep_tc rep_tc_args mtheta
659
660
661
662
663
  = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
	-- NB: pass the *representation* tycon to checkSideConditions
	CanDerive               -> go_for_it
	NonDerivableClass	-> bale_out (nonStdErr cls)
	DerivableClassError msg -> bale_out msg
664
  where
665
    go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
666
    bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
667

668
669
mk_data_eqn, mk_typeable_eqn
   :: InstOrigin -> [TyVar] -> Class 
670
   -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
671
   -> TcM EarlyDerivSpec
672
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
673
674
  | getName cls `elem` typeableClassNames
  = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
675
676
677

  | otherwise
  = do	{ dfun_name <- new_dfun_name cls tycon
678
  	; loc <- getSrcSpanM
679
680
	; let inst_tys = [mkTyConApp tycon tc_args]
	      inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
681
682
	      spec = DS { ds_loc = loc, ds_orig = orig
			, ds_name = dfun_name, ds_tvs = tvs 
683
684
			, ds_cls = cls, ds_tys = inst_tys
			, ds_tc = rep_tc, ds_tc_args = rep_tc_args
685
			, ds_theta =  mtheta `orElse` inferred_constraints
686
687
			, ds_newtype = False }

688
  	; return (if isJust mtheta then Right spec	-- Specified context
689
				   else Left spec) }	-- Infer context
690

691
mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
692
693
694
695
696
697
698
699
700
701
702
	-- The Typeable class is special in several ways
	-- 	  data T a b = ... deriving( Typeable )
	-- gives
	--	  instance Typeable2 T where ...
	-- Notice that:
	-- 1. There are no constraints in the instance
	-- 2. There are no type variables either
	-- 3. The actual class we want to generate isn't necessarily
	--	Typeable; it depends on the arity of the type
  | isNothing mtheta	-- deriving on a data type decl
  = do	{ checkTc (cls `hasKey` typeableClassKey)
Ian Lynagh's avatar
Ian Lynagh committed
703
		  (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
704
705
706
707
708
	; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
	; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }

  | otherwise		-- standaone deriving
  = do	{ checkTc (null tc_args)
Ian Lynagh's avatar
Ian Lynagh committed
709
		  (ptext (sLit "Derived typeable instance must be of form (Typeable") 
710
711
712
			<> int (tyConArity tycon) <+> ppr tycon <> rparen)
	; dfun_name <- new_dfun_name cls tycon
  	; loc <- getSrcSpanM
713
	; return (Right $
714
		  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
715
716
		     , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
		     , ds_tc = rep_tc, ds_tc_args = rep_tc_args
717
718
		     , ds_theta = mtheta `orElse` [], ds_newtype = False })  }

719

720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
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
763
764
765
766
767
768
769
770
771
772
773
774
inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
-- Generate a sufficiently large set of constraints that typechecking the
-- generated method definitions should succeed.   This set will be simplified
-- before being used in the instance declaration
inferConstraints tvs cls inst_tys rep_tc rep_tc_args
  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
    stupid_constraints ++ extra_constraints
    ++ sc_constraints ++ con_arg_constraints
  where
       -- Constraints arising from the arguments of each constructor
    con_arg_constraints
      = [ mkClassPred cls [arg_ty] 
        | data_con <- tyConDataCons rep_tc,
          arg_ty   <- ASSERT( isVanillaDataCon data_con )
    			get_constrained_tys $
    		 	dataConInstOrigArgTys data_con all_rep_tc_args,
          not (isUnLiftedType arg_ty) ]
    		-- No constraints for unlifted types
    		-- Where they are legal we generate specilised function calls

    		-- For functor-like classes, two things are different
    		-- (a) We recurse over argument types to generate constraints
    		--     See Functor examples in TcGenDeriv
    		-- (b) The rep_tc_args will be one short
    is_functor_like = getUnique cls `elem` functorLikeClassKeys

    get_constrained_tys :: [Type] -> [Type]
    get_constrained_tys tys 
    	| is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
    	| otherwise	  = tys

    rep_tc_tvs = tyConTyVars rep_tc
    last_tv = last rep_tc_tvs
    all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
    		    | otherwise       = rep_tc_args

    	-- Constraints arising from superclasses
    	-- See Note [Superclasses of derived instance]
    sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
    				(classSCTheta cls)

    	-- Stupid constraints
    stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
    subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
	      
	-- Extra constraints
	-- The Data class (only) requires that for 
	--    instance (...) => Data (T a b) 
	-- then (Data a, Data b) are among the (...) constraints
	-- Reason: that's what you need to typecheck the method
	-- 	       dataCast1 f = gcast1 f
    extra_constraints 
      | cls `hasKey` dataClassKey = [mkClassPred cls [mkTyVarTy tv] | tv <- tvs]
      | otherwise    		  = []

775
776
777
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
778
779
780
781
--
-- Here we get the representation tycon in case of family instances as it has
-- the data constructors - but we need to be careful to fall back to the
-- family tycon (with indexes) in error messages.
782

783
data DerivStatus = CanDerive
784
785
		 | DerivableClassError SDoc	-- Standard class, but can't do it
     		 | NonDerivableClass		-- Non-standard class
786

787
788
789
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus
checkSideConditions dflags mtheta cls cls_tys rep_tc
  | Just cond <- sideConditions mtheta cls
790
  = case (cond (dflags, rep_tc)) of
791
	Just err -> DerivableClassError err	-- Class-specific error
792
793
794
	Nothing  | null cls_tys -> CanDerive	-- All derivable classes are unary, so
						-- cls_tys (the type args other than last) 
						-- should be null
795
796
		 | otherwise    -> DerivableClassError ty_args_why	-- e.g. deriving( Eq s )
  | otherwise = NonDerivableClass	-- Not a standard class
797
  where
Ian Lynagh's avatar
Ian Lynagh committed
798
    ty_args_why	= quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
799
800
801

nonStdErr :: Class -> SDoc
nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
802

803
804
sideConditions :: DerivContext -> Class -> Maybe Condition
sideConditions mtheta cls
805
806
807
808
809
810
811
  | cls_key == eqClassKey      	   = Just cond_std
  | cls_key == ordClassKey     	   = Just cond_std
  | cls_key == showClassKey    	   = Just cond_std
  | cls_key == readClassKey    	   = Just (cond_std `andCond` cond_noUnliftedArgs)
  | cls_key == enumClassKey    	   = Just (cond_std `andCond` cond_isEnumeration)
  | cls_key == ixClassKey      	   = Just (cond_std `andCond` cond_enumOrProduct)
  | cls_key == boundedClassKey 	   = Just (cond_std `andCond` cond_enumOrProduct)
812
813
814
815
816
817
818
819
820
  | cls_key == dataClassKey    	   = Just (checkFlag Opt_DeriveDataTypeable `andCond` 
                                           cond_std `andCond` cond_noUnliftedArgs)
  | cls_key == functorClassKey 	   = Just (checkFlag Opt_DeriveFunctor `andCond`
    	                                   cond_functorOK True)	 -- NB: no cond_std!
  | cls_key == foldableClassKey	   = Just (checkFlag Opt_DeriveFoldable `andCond`
    	                                   cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
  | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
    	                                   cond_functorOK False)
  | getName cls `elem` typeableClassNames = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK)
821
822
823
  | otherwise = Nothing
  where
    cls_key = getUnique cls
824
    cond_std = cond_stdOK mtheta
825

826
827
828
type Condition = (DynFlags, TyCon) -> Maybe SDoc
	-- first Bool is whether or not we are allowed to derive Data and Typeable
	-- second Bool is whether or not we are allowed to derive Functor
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
829
830
831
	-- TyCon is the *representation* tycon if the 
	--	data type is an indexed one
	-- Nothing => OK
832

833
834
835
836
837
838
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
Ian Lynagh's avatar
Ian Lynagh committed
839
		     Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
840
841
					-- Both fail

842
andCond :: Condition -> Condition -> Condition
843
844
845
846
andCond c1 c2 tc = case c1 tc of
		     Nothing -> c2 tc	-- c1 succeeds
		     Just x  -> Just x	-- c1 fails

847
848
849
850
851
852
853
cond_stdOK :: DerivContext -> Condition
cond_stdOK (Just _) _
  = Nothing	-- Don't check these conservative conditions for
		-- standalone deriving; just generate the code
cond_stdOK Nothing (_, rep_tc)
  | null data_cons      = Just (no_cons_why $$ suggestion)
  | not (null con_whys) = Just (vcat con_whys $$ suggestion)
854
  | otherwise      	= Nothing
855
  where
856
857
858
859
    suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
    data_cons   = tyConDataCons rep_tc
    no_cons_why	= quotes (pprSourceTyCon rep_tc) <+> 
		  ptext (sLit "has no data constructors")
860
861
862
863
864
865
866
867

    con_whys = mapCatMaybes check_con data_cons

    check_con :: DataCon -> Maybe SDoc
    check_con con 
      | isVanillaDataCon con
      , all isTauTy (dataConOrigArgTys con) = Nothing
      | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
868
  
869
870
871
872
873
874
875
876
877
878
879
880
881
cond_enumOrProduct :: Condition
cond_enumOrProduct = cond_isEnumeration `orCond` 
		       (cond_isProduct `andCond` cond_noUnliftedArgs)

cond_noUnliftedArgs :: Condition
-- For some classes (eg Eq, Ord) we allow unlifted arg types
-- by generating specilaised code.  For others (eg Data) we don't.
cond_noUnliftedArgs (_, tc)
  | null bad_cons = Nothing
  | otherwise     = Just why
  where
    bad_cons = [ con | con <- tyConDataCons tc
		     , any isUnLiftedType (dataConOrigArgTys con) ]
882
    why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
883

884
cond_isEnumeration :: Condition
885
cond_isEnumeration (_, rep_tc)
886
887
  | isEnumerationTyCon rep_tc = Nothing
  | otherwise		      = Just why
888
  where
889
    why = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
890
	  ptext (sLit "has non-nullary constructors")
891
892

cond_isProduct :: Condition
893
cond_isProduct (_, rep_tc)
894
895
  | isProductTyCon rep_tc = Nothing
  | otherwise	          = Just why
896
  where
897
    why = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
898
	  ptext (sLit "has more than one constructor")
899
900
901
902
903

cond_typeableOK :: Condition
-- OK for Typeable class
-- Currently: (a) args all of kind *
--	      (b) 7 or fewer args
904
cond_typeableOK (_, rep_tc)
905
906
  | tyConArity rep_tc > 7	= Just too_many
  | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc)) 
907
                                = Just bad_kind
908
  | isFamInstTyCon rep_tc	= Just fam_inst  -- no Typable for family insts
909
910
  | otherwise	  		= Nothing
  where
911
    too_many = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
912
	       ptext (sLit "has too many arguments")
913
    bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
914
	       ptext (sLit "has arguments of kind other than `*'")
915
    fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
916
	       ptext (sLit "is a type family")
917

918
919
920
921

functorLikeClassKeys :: [Unique]
functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]

922
923
924
925
926
927
cond_functorOK :: Bool -> Condition
-- OK for Functor class
-- Currently: (a) at least one argument
--            (b) don't use argument contravariantly
--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
--            (d) optionally: don't use function types
928
929
930
931
cond_functorOK allowFunctions (dflags, rep_tc) 
  | not (dopt Opt_DeriveFunctor dflags)
  = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
  | otherwise
932
  = msum (map check_con data_cons)	-- msum picks the first 'Just', if any
933
934
  where
    data_cons = tyConDataCons rep_tc
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
    check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)

    check_vanilla :: DataCon -> Maybe SDoc
    check_vanilla con | isVanillaDataCon con = Nothing
    		      | otherwise	     = Just (badCon con existential)

    ft_check :: DataCon -> FFoldType (Maybe SDoc)
    ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
                      , ft_co_var = Just (badCon con covariant)
	      	      , ft_fun = \x y -> if allowFunctions then x `mplus` y 
                                                           else Just (badCon con functions)
                      , ft_tup = \_ xs  -> msum xs
                      , ft_ty_app = \_ x   -> x
                      , ft_bad_app = Just (badCon con wrong_arg)
                      , ft_forall = \_ x   -> x }
950
                    
951
952
953
954
    existential = ptext (sLit "has existential arguments")
    covariant 	= ptext (sLit "uses the type variable in a function argument")
    functions 	= ptext (sLit "contains function types")
    wrong_arg 	= ptext (sLit "uses the type variable in an argument other than the last")
955

956
957
958
959
checkFlag :: DynFlag -> Condition
checkFlag flag (dflags, _)
  | dopt flag dflags = Nothing
  | otherwise        = Just why
960
  where
961
962
963
964
965
    why = ptext (sLit "You need -X") <> text flag_str 
          <+> ptext (sLit "to derive an instance for this class")
    flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
                 [s]   -> s
                 other -> pprPanic "checkFlag" (ppr other)
966

967
std_class_via_iso :: Class -> Bool
968
969
970
971
-- These standard classes can be derived for a newtype
-- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
-- because giving so gives the same results as generating the boilerplate
std_class_via_iso clas	
972
  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
973
	-- Not Read/Show because they respect the type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
974
	-- Not Enum, because newtypes are never in Enum
975
976


977
978
979
980
981
982
983
984
985
986
non_iso_class :: Class -> Bool
-- *Never* derive Read,Show,Typeable,Data by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls 
  = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
			 typeableClassKeys)

typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames

987
new_dfun_name :: Class -> TyCon -> TcM Name
988
new_dfun_name clas tycon 	-- Just a simple wrapper
989
990
  = do { loc <- getSrcSpanM	-- The location of the instance decl, not of the tycon
	; newDFunName clas [mkTyConApp tycon []] loc }
991
992
	-- The type passed to newDFunName is only used to generate
	-- a suitable string; hence the empty type arg list
993
994
995

badCon :: DataCon -> SDoc -> SDoc
badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
996
997
\end{code}

998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
Note [Superclasses of derived instance] 
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general, a derived instance decl needs the superclasses of the derived
class too.  So if we have
	data T a = ...deriving( Ord )
then the initial context for Ord (T a) should include Eq (T a).  Often this is 
redundant; we'll also generate an Ord constraint for each constructor argument,
and that will probably generate enough constraints to make the Eq (T a) constraint 
be satisfied too.  But not always; consider:

 data S a = S
 instance Eq (S a)
 instance Ord (S a)

 data T a = MkT (S a) deriving( Ord )
 instance Num a => Eq (T a)

The derived instance for (Ord (T a)) must have a (Num a) constraint!
Similarly consider:
	data T a = MkT deriving( Data, Typeable )
Here there *is* no argument field, but we must nevertheless generate
a context for the Data instances:
	instance Typable a => Data (T a) where ...

1022
1023
1024
1025
1026
1027
1028
1029

%************************************************************************
%*									*
		Deriving newtypes
%*									*
%************************************************************************

\begin{code}
1030
mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class
1031
             -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1032
             -> DerivContext
1033
             -> TcRn EarlyDerivSpec
1034
mkNewTypeEqn orig dflags tvs
1035
             cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1036
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1037
  | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1038
  = do	{ traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
1039
1040
1041
	; dfun_name <- new_dfun_name cls tycon
  	; loc <- getSrcSpanM
	; let spec = DS { ds_loc = loc, ds_orig = orig
1042
			, ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs 
1043
1044
			, ds_cls = cls, ds_tys = inst_tys
			, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1045
1046
			, ds_theta =  mtheta `orElse` all_preds
			, ds_newtype = True }
1047
1048
	; return (if isJust mtheta then Right spec
				   else Left spec) }
1049

1050
  | otherwise
1051
  = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1052
1053
1054
1055
      CanDerive -> go_for_it 	-- Use the standard H98 method
      DerivableClassError msg 	-- Error with standard class
        | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
        | otherwise                  -> bale_out msg
1056
      NonDerivableClass 	-- Must use newtype deriving
1057
1058
1059
      	| newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
        | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
      	| otherwise                  -> bale_out non_std
1060
  where
1061
        newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
1062
        go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1063
	bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1064

1065
1066
	non_std    = nonStdErr cls
        suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1067

1068
	-- Here is the plan for newtype derivings.  We see
1069
	--	  newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1070
	-- where t is a type,
1071
	-- 	 ak+1...an is a suffix of a1..an, and are all tyars
1072
	--	 ak+1...an do not occur free in t, nor in the s1..sm
1073
1074
	-- 	 (C s1 ... sm) is a  *partial applications* of class C 
	--			with the last parameter missing
1075
1076
	--	 (T a1 .. ak) matches the kind of C's last argument
	--		(and hence so does t)
1077
1078
	-- The latter kind-check has been done by deriveTyData already,
	-- and tc_args are already trimmed
1079
1080
1081
1082
1083
1084
	--
	-- We generate the instance
	--	 instance forall ({a1..ak} u fvs(s1..sm)).
	--		  C s1 .. sm t => C s1 .. sm (T a1...ak)
	-- where T a1...ap is the partial application of 
	-- 	 the LHS of the correct kind and p >= k
1085
	--
1086
1087
1088
1089
1090
1091
1092
	--	NB: the variables below are:
	--		tc_tvs = [a1, ..., an]
	--		tyvars_to_keep = [a1, ..., ak]
	--		rep_ty = t ak .. an
	--		deriv_tvs = fvs(s1..sm) \ tc_tvs
	--		tys = [s1, ..., sm]
	--		rep_fn' = t
1093
1094
	--
	-- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1095
	-- We generate the instance
1096
	--	instance Monad (ST s) => Monad (T s) where 
1097

1098
1099
	nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
		-- For newtype T a b = MkT (S a a b), the TyCon machinery already
1100
		-- eta-reduces the representation type, so we know that
1101
1102
1103
		-- 	T a ~ S a a
		-- That's convenient here, because we may have to apply
		-- it to fewer than its original complement of arguments
1104

1105
1106
1107
1108
	-- Note [Newtype representation]
	-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	-- Need newTyConRhs (*not* a recursive representation finder) 
	-- to get the representation type. For example
1109
1110
1111
1112
	--	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!
1113
1114
1115
	rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
	rep_tys     = cls_tys ++ [rep_inst_ty]
	rep_pred    = mkClassPred cls rep_tys
1116
		-- rep_pred is the representation dictionary, from where
1117
1118
1119
		-- we are gong to get all the methods for the newtype
		-- dictionary 

1120

1121
1122
    -- Next we figure out what superclass dictionaries to use
    -- See Note [Newtype deriving superclasses] above
1123

1124
	cls_tyvars = classTyVars cls
1125
	dfun_tvs = tyVarsOfTypes inst_tys
1126
1127
	inst_ty = mkTyConApp tycon tc_args
	inst_tys = cls_tys ++ [inst_ty]
1128
1129
	sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
			      (classSCTheta cls)
1130
1131
1132

		-- If there are no tyvars, there's no need
		-- to abstract over the dictionaries we need
1133
1134
1135
1136
1137
1138
		-- Example: 	newtype T = MkT Int deriving( C )
		-- We get the derived instance
		--		instance C T
		-- rather than
		--		instance C Int => C T
	all_preds = rep_pred : sc_theta		-- NB: rep_pred comes first
1139
1140
1141

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

1143
	can_derive_via_isomorphism
1144
	   =  not (non_iso_class cls)
1145
1146
1147
	   && arity_ok
	   && eta_ok
	   && ats_ok
1148
--	   && not (isRecursiveTyCon tycon)	-- Note [Recursive newtypes]
1149

1150
1151
1152
1153
	arity_ok = length cls_tys + 1 == classArity cls
 		-- Well kinded; eg not: newtype T ... deriving( ST )
		--			because ST needs *2* type params

1154
	-- Check that eta reduction is OK
1155
1156
	eta_ok = nt_eta_arity <= length rep_tc_args
		-- The newtype can be eta-reduced to match the number
1157
		--     of type argument actually supplied
1158
1159
		--	  newtype T a b = MkT (S [a] b) deriving( Monad )
		--     Here the 'b' must be the same in the rep type (S [a] b)
1160
1161
		--     And the [a] must not mention 'b'.  That's all handled
		--     by nt_eta_rity.
1162

1163
1164
1165
1166
1167
1168
	ats_ok = null (classATs cls)	
	       -- No associated types for the class, because we don't 
	       -- currently generate type 'instance' decls; and cannot do
	       -- so for 'data' instance decls
					 
	cant_derive_err
1169
	   = vcat [ ppUnless arity_ok arity_msg
1170
1171
		  , ppUnless eta_ok eta_msg
		  , ppUnless ats_ok ats_msg ]
1172
1173
1174
        arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
	eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
	ats_msg   = ptext (sLit "the class has associated types")
1175
1176
\end{code}

1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
Note [Recursive newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~
Newtype deriving works fine, even if the newtype is recursive.
e.g. 	newtype S1 = S1 [T1 ()]
	newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
Remember, too, that type families are curretly (conservatively) given
a recursive flag, so this also allows newtype deriving to work
for type famillies.

We used to exclude recursive types, because we had a rather simple
minded way of generating the instance decl:
   newtype A = MkA [A]
   instance Eq [A] => Eq A	-- Makes typechecker loop!
But now we require a simple context, so it's ok.

1192

1193
1194
1195
1196
1197
1198
%************************************************************************
%*									*
\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
%*									*
%************************************************************************

1199
A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1200
1201
1202
1203
terms, which is the final correct RHS for the corresponding original
equation.
\begin{itemize}
\item
1204
Each (k,TyVarTy tv) in a solution constrains only a type
1205
1206
1207
variable, tv.

\item
1208
The (k,TyVarTy tv) pairs in a solution are canonically
1209
1210
1211
1212
1213
ordered by sorting on type varible, tv, (major key) and then class, k,
(minor key)
\end{itemize}

\begin{code}
1214
1215
1216
1217
1218
1219
1220
inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]

inferInstanceContexts _ [] = return []

inferInstanceContexts oflag infer_specs
  = do	{ traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
	; iterate_deriv 1 initial_solutions }
1221
  where
1222
    ------------------------------------------------------------------
1223
1224
1225
	-- The initial solutions for the equations claim that each
	-- instance has an empty context; this solution is certainly
	-- in canonical form.
1226
1227
    initial_solutions :: [ThetaType]
    initial_solutions = [ [] | _ <- infer_specs ]
1228

1229
    ------------------------------------------------------------------
1230
	-- iterate_deriv calculates the next batch of solutions,
1231
1232
	-- compares it with the current one; finishes if they are the
	-- same, otherwise recurses with the new solutions.
1233
	-- It fails if any iteration fails
1234
1235
    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
    iterate_deriv n current_solns
1236
      | n > 20 	-- Looks as if we are in an infinite loop
1237
		-- This can happen if we have -XUndecidableInstances
1238
1239
		-- (See TcSimplify.tcSimplifyDeriv.)
      = pprPanic "solveDerivEqns: probable loop" 
1240
		 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1241
      | otherwise
1242
      =	do { 	  -- Extend the inst info from the explicit instance decls
1243
		  -- with the current set of solutions, and simplify each RHS
1244
	     let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
					   current_solns infer_specs
	   ; new_solns <- checkNoErrs $
	     		  extendLocalInstEnv inst_specs $
	     		  mapM gen_soln infer_specs

	   ; if (current_solns == new_solns) then
		return [ spec { ds_theta = soln } 
                       | (spec, soln) <- zip infer_specs current_solns ]
	     else
		iterate_deriv (n+1) new_solns }
1255
1256

    ------------------------------------------------------------------
1257
1258
1259
    gen_soln :: DerivSpec  -> TcM [PredType]
    gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars 
		 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1260
      = setSrcSpan loc	$
1261
	addErrCtxt (derivInstCtxt clas inst_tys) $ 
1262
	do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
1263
	   	-- checkValidInstance tyvars theta clas inst_tys
1264
1265
		-- Not necessary; see Note [Exotic derived instance contexts]
		-- 		  in TcSimplify
1266