TcDeriv.lhs 44.7 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 33 34 35 36 37 38 39 40 41 42 43
import TcSimplify

import RnBinds
import RnEnv
import HscTypes

import Class
import Type
import ErrUtils
import MkId
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
import VarSet
44
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
45 46 47
import SrcLoc
import Util
import ListSetOps
48
import Outputable
49
import FastString
50
import Bag
51 52 53 54
\end{code}

%************************************************************************
%*									*
55
		Overview
56 57 58
%*									*
%************************************************************************

59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
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]
		     , 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
	-- For family indexes, the tycon is the *family* tycon
	--		(not the representation tycon)

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

type EarlyDerivSpec = Either DerivSpec DerivSpec
	-- Left  ds => the context for the instance should be inferred
90 91 92 93 94 95 96
	--	       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
97 98 99 100 101 102 103 104 105 106 107

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 
~~~~~~~~~~~~~~~~~~~~~~~~~~
108 109
Consider

110 111
	data T a b = C1 (Foo a) (Bar b)
		   | C2 Int (T b a)
112 113 114
		   | C3 (T a a)
		   deriving (Eq)

115 116 117 118
[NOTE: See end of these comments for what to do with 
	data (C a, D b) => T a b = ...
]

119 120 121 122 123 124 125 126 127 128 129 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
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:
170
		   = Eq a u Ping b
171 172
		   u (Eq b u Ping a)
		   u (Eq a u Ping a)
173

174 175 176 177 178 179 180 181 182 183 184 185
		   = 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:

186

187 188
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209
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?

210 211 212 213 214
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".

215 216
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
217 218 219 220 221 222 223 224 225 226 227 228
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 ...
    
	
229 230
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
231 232 233
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
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


253

254

255 256 257 258 259 260 261
%************************************************************************
%*									*
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
%*									*
%************************************************************************

\begin{code}
262 263
tcDeriving  :: [LTyClDecl Name]  -- All type constructors
            -> [LInstDecl Name]  -- All instance declarations
264
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
265
	    -> TcM ([InstInfo Name],	-- The generated "instance decls"
266
		    HsValBinds Name)	-- Extra generated top-level bindings
267

268
tcDeriving tycl_decls inst_decls deriv_decls
269
  = recoverM (return ([], emptyValBindsOut)) $
270
    do	{   	-- Fish the "deriving"-related information out of the TcEnv
271 272
		-- And make the necessary "equations".
	; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
273

274 275
	; overlap_flag <- getOverlapFlag
	; let (infer_specs, given_specs) = splitEithers early_specs
276
	; insts1 <- mapM (genInst overlap_flag) given_specs
277

278
	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
279
			 inferInstanceContexts overlap_flag infer_specs
280

281
	; insts2 <- mapM (genInst overlap_flag) final_specs
282

283
	; is_boot <- tcIsHsBoot
284 285 286
		 -- Generate the generic to/from functions from each type declaration
	; gen_binds <- mkGenericBinds is_boot
	; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
287

288
	; dflags <- getDOpts
twanvl's avatar
twanvl committed
289 290
	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
	         (ddump_deriving inst_info rn_binds))
291

292
	; return (inst_info, rn_binds) }
293
  where
294
    ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
295
    ddump_deriving inst_infos extra_binds
296
      = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
297

298 299 300 301 302 303 304 305 306
renameDeriv :: Bool -> LHsBinds RdrName
	    -> [(InstInfo RdrName, DerivAuxBinds)]
 	    -> TcM ([InstInfo Name], HsValBinds Name)
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
  = do	{ rn_inst_infos <- mapM rn_inst_info inst_infos	
	; return (rn_inst_infos, emptyValBindsOut) }
307

308
  | otherwise
309 310 311 312 313 314 315
  = discardWarnings $ 	 -- Discard warnings about unused bindings etc
    do	{ (rn_gen, dus_gen) <- setOptM Opt_PatternSignatures $	-- Type signatures in patterns 
								-- are used in the generic binds
			       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, 
316
		-- notably "con2tag" and/or "tag2con" functions.  
317 318 319 320 321 322 323 324 325 326 327
		-- 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 [])
	; let aux_names =  map unLoc (collectHsValBinders rn_aux_lhs)

	; bindLocalNames aux_names $ 
    do	{ (rn_aux, _dus) <- rnTopBindsRHS aux_names rn_aux_lhs
	; rn_inst_infos <- mapM rn_inst_info inst_infos
	; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen) } }
328

329
  where
330 331
    (inst_infos, deriv_aux_binds) = unzip insts
    
332 333 334 335
	-- 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
336

337 338 339 340 341 342 343 344 345 346 347 348 349 350 351

    rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived })
	= return (InstInfo { iSpec = inst, iBinds = NewTypeDerived })

    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
	= 	-- Bring the right type variables into 
		-- scope (yuk), and rename the method binds
	   ASSERT( null sigs )
	   bindLocalNames (map Var.varName tyvars) $
 	   do { (rn_binds, _fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
	      ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }) }
	where
	  (tyvars,_,clas,_) = instanceHead inst
	  clas_nm  	    = className clas

352
-----------------------------------------
353 354 355 356 357 358 359
mkGenericBinds :: Bool -> TcM (LHsBinds RdrName)
mkGenericBinds is_boot
  | is_boot 
  = return emptyBag
  | otherwise
  = do	{ gbl_env <- getGblEnv
	; let tcs = typeEnvTyCons (tcg_type_env gbl_env)
360 361
	; return (unionManyBags [ mkTyConGenericBinds tc | 
				  tc <- tcs, tyConHasGenerics tc ]) }
362 363 364
		-- 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
365 366 367 368 369
\end{code}


%************************************************************************
%*									*
370
		From HsSyn to DerivSpec
371 372 373
%*									*
%************************************************************************

374
@makeDerivSpecs@ fishes around to find the info about needed derived
375 376 377 378 379 380 381 382 383 384 385 386 387 388 389
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}
390 391 392 393
makeDerivSpecs :: [LTyClDecl Name] 
               -> [LInstDecl Name]
	       -> [LDerivDecl Name] 
	       -> TcM [EarlyDerivSpec]
394

395
makeDerivSpecs tycl_decls inst_decls deriv_decls
396
  = do	{ eqns1 <- mapAndRecoverM deriveTyData $
397 398 399 400
                     extractTyDataPreds tycl_decls ++
		     [ pd                        -- traverse assoc data families
                     | L _ (InstDecl _ _ _ ats) <- inst_decls
		     , pd <- extractTyDataPreds ats ]
401
	; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
402
	; return (catMaybes (eqns1 ++ eqns2)) }
403 404 405 406
  where
    extractTyDataPreds decls = 		   
      [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]

407 408

------------------------------------------------------------------
409
deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec)
410
-- Standalone deriving declarations
411
--  e.g.   deriving instance show a => Show (T a)
412 413 414 415
-- Rather like tcLocalInstDecl
deriveStandalone (L loc (DerivDecl deriv_ty))
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
416 417 418 419 420 421 422
    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)
       ; (cls, inst_tys) <- checkValidInstHead tau
423 424 425
       ; checkValidInstance tvs theta cls inst_tys
		-- C.f. TcInstDcls.tcLocalInstDecl1

426 427 428 429 430 431 432 433
       ; 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) }
434 435

------------------------------------------------------------------
436
deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)
437 438 439 440 441
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 $
442 443 444 445 446 447 448 449 450 451
    do	{ let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
	      hs_app     = nlHsTyConApp tycon_name hs_ty_args
		-- We get kinding info for the tyvars by typechecking (T a b)
		-- Hence forming a tycon application and then dis-assembling it
	; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
	; tcExtendTyVarEnv tvs $	-- Deriving preds may (now) mention
					-- the type variables for the type constructor
    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]).
452
	; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }
453 454

deriveTyData _other
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
455
  = panic "derivTyData"	-- Caller ensures that only TyData can happen
456 457

------------------------------------------------------------------
458
mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
459 460
          -> Maybe ThetaType	-- Just    => context supplied (standalone deriving)
				-- Nothing => context inferred (deriving on data decl)
461
          -> TcRn (Maybe EarlyDerivSpec)
462
mkEqnHelp orig tvs cls cls_tys tc_app mtheta
463
  | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
464 465 466 467 468
  , 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

469
	-- For standalone deriving (mtheta /= Nothing), 
470 471 472
	-- 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.
473 474
	-- By this time we know that the thing is algebraic
	--	because we've called checkInstHead in derivingStandalone
475 476 477
	; 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))
478 479 480
	; checkTc (isNothing mtheta || 
	  	   not hidden_data_cons ||
		   className cls `elem` typeableClassNames) 
481
		  (derivingHiddenErr tycon)
482

483
	; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
484
	; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
485 486

	; if isDataTyCon rep_tc then
487 488
		mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys 
			      tycon tc_args rep_tc rep_tc_args mtheta
489
	  else
490
		mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
491 492
		             tvs cls cls_tys 
			     tycon tc_args rep_tc rep_tc_args mtheta }
493 494
  | otherwise
  = baleOut (derivingThingErr cls cls_tys tc_app
495
	    (ptext (sLit "The last argument of the instance must be a data or newtype application")))
496

497 498
baleOut :: Message -> TcM (Maybe a)
baleOut err = do { addErrTc err;  return Nothing }
499 500
\end{code}

501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523
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.
524 525 526 527

\begin{code}
tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
tcLookupFamInstExact tycon tys
528 529 530 531 532
  | not (isOpenTyCon tycon)
  = return (tycon, tys)
  | otherwise
  = do { maybeFamInst <- tcLookupFamInst tycon tys
       ; case maybeFamInst of
533 534
           Nothing      -> famInstNotFound tycon tys
           Just famInst -> return famInst
535
       }
536 537 538 539

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

543 544 545 546 547 548 549 550

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

\begin{code}
551
mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
552 553 554
              -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType
              -> TcRn (Maybe EarlyDerivSpec)	-- Return 'Nothing' if error
		
555
mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
556
              tycon tc_args rep_tc rep_tc_args mtheta
557
  | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
558
	-- NB: pass the *representation* tycon to checkSideConditions
559 560 561 562
  = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)

  | otherwise 
  = ASSERT( null cls_tys )
563 564
    mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta

565 566 567 568
mk_data_eqn, mk_typeable_eqn
   :: InstOrigin -> [TyVar] -> Class 
   -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
   -> TcM (Maybe EarlyDerivSpec)
569
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
570 571
  | getName cls `elem` typeableClassNames
  = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
572 573 574

  | otherwise
  = do	{ dfun_name <- new_dfun_name cls tycon
575
  	; loc <- getSrcSpanM
576 577 578
	; let ordinary_constraints
	        = [ mkClassPred cls [arg_ty] 
	          | data_con <- tyConDataCons rep_tc,
579 580
	            arg_ty   <- ASSERT( isVanillaDataCon data_con )
				dataConInstOrigArgTys data_con rep_tc_args,
581 582
	            not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?

583 584 585 586 587
			-- See Note [Superclasses of derived instance]
	      sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
					  (classSCTheta cls)
	      inst_tys =  [mkTyConApp tycon tc_args]

588 589
	      stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
	      stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
590
	      all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
591

592 593
	      spec = DS { ds_loc = loc, ds_orig = orig
			, ds_name = dfun_name, ds_tvs = tvs 
594
			, ds_cls = cls, ds_tys = inst_tys
595 596 597 598 599
			, ds_theta =  mtheta `orElse` all_constraints
			, ds_newtype = False }

  	; return (if isJust mtheta then Just (Right spec)	-- Specified context
				   else Just (Left spec)) }	-- Infer context
600

601 602 603 604 605 606 607 608 609 610 611 612
mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
	-- 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
613
		  (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
614 615 616 617 618
	; 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
619
		  (ptext (sLit "Derived typeable instance must be of form (Typeable") 
620 621 622 623 624 625 626 627
			<> int (tyConArity tycon) <+> ppr tycon <> rparen)
	; dfun_name <- new_dfun_name cls tycon
  	; loc <- getSrcSpanM
	; return (Just $ Right $
		  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
		     , ds_cls = cls, ds_tys = [mkTyConApp tycon []] 
		     , ds_theta = mtheta `orElse` [], ds_newtype = False })  }

628 629 630
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
631 632 633 634
--
-- 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.
635

636
checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
637
checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
638 639 640
  | notNull cls_tys	
  = Just ty_args_why	-- e.g. deriving( Foo s )
  | otherwise
641 642 643
  = case sideConditions cls of
	Just cond -> cond (mayDeriveDataTypeable, rep_tc)
	Nothing   -> Just non_std_why
644
  where
Ian Lynagh's avatar
Ian Lynagh committed
645 646
    ty_args_why	= quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
    non_std_why = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
647 648 649 650 651 652 653 654 655 656 657 658 659 660 661

sideConditions :: Class -> Maybe Condition
sideConditions cls
  | cls_key == eqClassKey   = Just cond_std
  | cls_key == ordClassKey  = Just cond_std
  | cls_key == readClassKey = Just cond_std
  | cls_key == showClassKey = Just cond_std
  | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
  | cls_key == ixClassKey   = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
  | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
  | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
  | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
  | otherwise = Nothing
  where
    cls_key = getUnique cls
662

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
663
type Condition = (Bool, TyCon) -> Maybe SDoc
664
	-- Bool is whether or not we are allowed to derive Data and Typeable
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
665 666 667
	-- TyCon is the *representation* tycon if the 
	--	data type is an indexed one
	-- Nothing => OK
668

669 670 671 672 673 674
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
675
		     Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
676 677
					-- Both fail

678
andCond :: Condition -> Condition -> Condition
679 680 681 682 683
andCond c1 c2 tc = case c1 tc of
		     Nothing -> c2 tc	-- c1 succeeds
		     Just x  -> Just x	-- c1 fails

cond_std :: Condition
684
cond_std (_, rep_tc)
685 686 687 688
  | any (not . isVanillaDataCon) data_cons = Just existential_why     
  | null data_cons		    	   = Just no_cons_why
  | otherwise      			   = Nothing
  where
689 690
    data_cons       = tyConDataCons rep_tc
    no_cons_why	    = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
691
		      ptext (sLit "has no data constructors")
692
    existential_why = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
693
		      ptext (sLit "has non-Haskell-98 constructor(s)")
694 695
  
cond_isEnumeration :: Condition
696
cond_isEnumeration (_, rep_tc)
697 698
  | isEnumerationTyCon rep_tc = Nothing
  | otherwise		      = Just why
699
  where
700
    why = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
701
	  ptext (sLit "has non-nullary constructors")
702 703

cond_isProduct :: Condition
704
cond_isProduct (_, rep_tc)
705 706
  | isProductTyCon rep_tc = Nothing
  | otherwise	          = Just why
707
  where
708
    why = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
709
	  ptext (sLit "has more than one constructor")
710 711 712 713 714

cond_typeableOK :: Condition
-- OK for Typeable class
-- Currently: (a) args all of kind *
--	      (b) 7 or fewer args
715
cond_typeableOK (_, rep_tc)
716 717
  | tyConArity rep_tc > 7	= Just too_many
  | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc)) 
718
                                = Just bad_kind
719
  | isFamInstTyCon rep_tc	= Just fam_inst  -- no Typable for family insts
720 721
  | otherwise	  		= Nothing
  where
722
    too_many = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
723
	       ptext (sLit "has too many arguments")
724
    bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
725
	       ptext (sLit "has arguments of kind other than `*'")
726
    fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
727
	       ptext (sLit "is a type family")
728

729 730 731 732
cond_mayDeriveDataTypeable :: Condition
cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
 | mayDeriveDataTypeable = Nothing
 | otherwise = Just why
733
  where
Ian Lynagh's avatar
Ian Lynagh committed
734
    why  = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
735

736
std_class_via_iso :: Class -> Bool
737 738 739 740
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
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
741
	-- Not Enum, because newtypes are never in Enum
742 743


744
new_dfun_name :: Class -> TyCon -> TcM Name
745
new_dfun_name clas tycon 	-- Just a simple wrapper
746 747
  = do { loc <- getSrcSpanM	-- The location of the instance decl, not of the tycon
	; newDFunName clas [mkTyConApp tycon []] loc }
748 749 750 751
	-- The type passed to newDFunName is only used to generate
	-- a suitable string; hence the empty type arg list
\end{code}

752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775
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 ...

776 777 778 779 780 781 782 783

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

\begin{code}
784
mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
785
             -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
786 787 788
             -> Maybe ThetaType
             -> TcRn (Maybe EarlyDerivSpec)
mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
789
             cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
790
  | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
791
  = do	{ traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
792 793 794 795 796 797 798 799 800
	; dfun_name <- new_dfun_name cls tycon
  	; loc <- getSrcSpanM
	; let spec = DS { ds_loc = loc, ds_orig = orig
			, ds_name = dfun_name, ds_tvs = dict_tvs 
			, ds_cls = cls, ds_tys = inst_tys
			, ds_theta =  mtheta `orElse` all_preds
			, ds_newtype = True }
	; return (if isJust mtheta then Just (Right spec)
				   else Just (Left spec)) }
801 802

  | isNothing mb_std_err	-- Use the standard H98 method
803
  = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
804 805

  	-- Otherwise we can't derive
806
  | newtype_deriving = baleOut cant_derive_err -- Too hard
807
  | otherwise        = baleOut std_err		-- Just complain about being a non-std instance
808
  where
809
	mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
810 811
	std_err = derivingThingErr cls cls_tys tc_app $
		  vcat [fromJust mb_std_err,
Ian Lynagh's avatar
Ian Lynagh committed
812
			ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
813

814
	-- Here is the plan for newtype derivings.  We see
815
	--	  newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
816
	-- where t is a type,
817
	-- 	 ak+1...an is a suffix of a1..an, and are all tyars
818
	--	 ak+1...an do not occur free in t, nor in the s1..sm
819 820
	-- 	 (C s1 ... sm) is a  *partial applications* of class C 
	--			with the last parameter missing
821 822 823 824 825 826 827 828
	--	 (T a1 .. ak) matches the kind of C's last argument
	--		(and hence so does t)
	--
	-- 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
829
	--
830 831 832 833 834 835 836
	--	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
837 838
	--
	-- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
839
	-- We generate the instance
840
	--	instance Monad (ST s) => Monad (T s) where 
841

842 843
	cls_tyvars = classTyVars cls
	kind = tyVarKind (last cls_tyvars)
844 845
		-- Kind of the thing we want to instance
		--   e.g. argument kind of Monad, *->*
846

847
	(arg_kinds, _) = splitKindFunTys kind
848 849 850 851
	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)

852 853 854 855
	-- Note [Newtype representation]
	-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	-- Need newTyConRhs (*not* a recursive representation finder) 
	-- to get the representation type. For example
856 857 858 859
	--	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!
860
	rep_ty		      = newTyConInstRhs rep_tycon rep_tc_args
861
	(rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
862

863 864 865
	n_tyargs_to_keep = tyConArity tycon - n_args_to_drop
	dropped_tc_args = drop n_tyargs_to_keep tc_args
	dropped_tvs     = tyVarsOfTypes dropped_tc_args
866

867
	n_args_to_keep = length rep_ty_args - n_args_to_drop
868
	args_to_drop   = drop n_args_to_keep rep_ty_args
869
	args_to_keep   = take n_args_to_keep rep_ty_args
870

871
	rep_fn'  = mkAppTys rep_fn args_to_keep
872 873
	rep_tys  = cls_tys ++ [rep_fn']
	rep_pred = mkClassPred cls rep_tys
874
		-- rep_pred is the representation dictionary, from where
875 876 877
		-- we are gong to get all the methods for the newtype
		-- dictionary 

878
	tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)
879

880 881
    -- Next we figure out what superclass dictionaries to use
    -- See Note [Newtype deriving superclasses] above
882

883 884 885
	inst_tys = cls_tys ++ [tc_app]
	sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
			      (classSCTheta cls)
886 887 888

		-- If there are no tyvars, there's no need
		-- to abstract over the dictionaries we need
889 890 891 892 893
		-- Example: 	newtype T = MkT Int deriving( C )
		-- We get the derived instance
		--		instance C T
		-- rather than
		--		instance C Int => C T
894
	dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs
895
	all_preds = rep_pred : sc_theta		-- NB: rep_pred comes first
896 897 898

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

900
	right_arity = length cls_tys + 1 == classArity cls
901

902
		-- Never derive Read,Show,Typeable,Data this way 
903 904
	non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
					  	  typeableClassNames)
905
	can_derive_via_isomorphism
906
	   =  not (non_iso_class cls)
907
	   && right_arity 			-- Well kinded;
908 909
						-- eg not: newtype T ... deriving( ST )
						--	because ST needs *2* type params
910
	   && n_tyargs_to_keep >= 0		-- Type constructor has right kind:
911
						-- eg not: newtype T = T Int deriving( Monad )
912
	   && n_args_to_keep   >= 0		-- Rep type has right kind: 
913 914
						-- eg not: newtype T a = T Int deriving( Monad )
	   && eta_ok				-- Eta reduction works
915 916 917 918
	   && not (isRecursiveTyCon tycon)	-- Does not work for recursive tycons:
						--	newtype A = MkA [A]
						-- Don't want
						--	instance Eq [A] => Eq A !!
919 920 921 922
			-- 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.
923 924 925 926
			-- 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
927

928
	-- Check that eta reduction is OK
929 930 931 932 933
	eta_ok = (args_to_drop `tcEqTypes` dropped_tc_args)
		-- (a) the dropped-off args are identical in the source and rep type
		--	  newtype T a b = MkT (S [a] b) deriving( Monad )
		--     Here the 'b' must be the same in the rep type (S [a] b)

934
	      && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
935 936 937 938 939 940
		-- (b) the remaining type args do not mention any of the dropped
		--     type variables 

	      && (tyVarsOfTypes cls_tys `disjointVarSet` dropped_tvs)
		-- (c) the type class args do not mention any of the dropped type
		--     variables 
941

942 943 944
	      && all isTyVarTy dropped_tc_args
		-- (d) in case of newtype family instances, the eta-dropped
		--      arguments must be type variables (not more complex indexes)
945

946
	cant_derive_err = derivingThingErr cls cls_tys tc_app
Ian Lynagh's avatar
Ian Lynagh committed
947
				(vcat [ptext (sLit "even with cunning newtype deriving:"),
948
					if isRecursiveTyCon tycon then
Ian Lynagh's avatar
Ian Lynagh committed
949
					  ptext (sLit "the newtype may be recursive")
950 951
					else empty,
					if not right_arity then 
Ian Lynagh's avatar
Ian Lynagh committed
952
					  quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
953
					else empty,
954
					if not (n_tyargs_to_keep >= 0) then 
Ian Lynagh's avatar
Ian Lynagh committed
955
					  ptext (sLit "the type constructor has wrong kind")
956
					else if not (n_args_to_keep >= 0) then
Ian Lynagh's avatar
Ian Lynagh committed
957
					  ptext (sLit "the representation type has wrong kind")
958
					else if not eta_ok then 
Ian Lynagh's avatar
Ian Lynagh committed
959
					  ptext (sLit "the eta-reduction property does not hold")
960
					else empty
961
				      ])
962 963
\end{code}

964

965 966 967 968 969 970
%************************************************************************
%*									*
\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
%*									*
%************************************************************************

971
A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
972 973 974 975
terms, which is the final correct RHS for the corresponding original
equation.
\begin{itemize}
\item
976
Each (k,TyVarTy tv) in a solution constrains only a type
977 978 979
variable, tv.

\item
980
The (k,TyVarTy tv) pairs in a solution are canonically
981 982 983 984 985
ordered by sorting on type varible, tv, (major key) and then class, k,
(minor key)
\end{itemize}

\begin{code}
986 987 988 989 990 991 992
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 }
993
  where
994
    ------------------------------------------------------------------
995 996 997
	-- The initial solutions for the equations claim that each
	-- instance has an empty context; this solution is certainly
	-- in canonical form.
998 999
    initial_solutions :: [ThetaType]
    initial_solutions = [ [] | _ <- infer_specs ]
1000

1001
    ------------------------------------------------------------------
1002
	-- iterate_deriv calculates the next batch of solutions,
1003 1004
	-- compares it with the current one; finishes if they are the
	-- same, otherwise recurses with the new solutions.
1005
	-- It fails if any iteration fails
1006 1007
    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
    iterate_deriv n current_solns
1008
      | n > 20 	-- Looks as if we are in an infinite loop
1009
		-- This can happen if we have -XUndecidableInstances
1010 1011
		-- (See TcSimplify.tcSimplifyDeriv.)
      = pprPanic "solveDerivEqns: probable loop" 
1012
		 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1013
      | otherwise
1014
      =	do { 	  -- Extend the inst info from the explicit instance decls
1015
		  -- with the current set of solutions, and simplify each RHS
1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026
	     let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag)
					   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 }
1027 1028

    ------------------------------------------------------------------
1029 1030 1031
    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 })
1032
      = setSrcSpan loc	$
1033
	addErrCtxt (derivInstCtxt clas inst_tys) $ 
1034
	do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
1035
	   	-- checkValidInstance tyvars theta clas inst_tys
1036 1037
		-- Not necessary; see Note [Exotic derived instance contexts]
		-- 		  in TcSimplify
1038 1039 1040 1041 1042 1043 1044 1045 1046 1047

		  -- Check for a bizarre corner case, when the derived instance decl should
		  -- have form 	instance C a b => D (T a) where ...
		  -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
		  -- of problems; in particular, it's hard to compare solutions for
		  -- equality when finding the fixpoint.  So I just rule it out for now.
 	   ; let tv_set = mkVarSet tyvars
	         weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]  
	   ; mapM_ (addErrTc . badDerivedPred) weird_preds	

simonpj@microsoft.com's avatar