2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Handles @deriving@ clauses on @data@ declarations.
9 module TcDeriv ( tcDeriving ) where
11 #include "HsVersions.h"
19 import TcClassDcl( tcAddDeclCtxt ) -- Small helper
20 import TcGenDeriv -- Deriv stuff
59 %************************************************************************
63 %************************************************************************
67 1. Convert the decls (i.e. data/newtype deriving clauses,
68 plus standalone deriving) to [EarlyDerivSpec]
70 2. Infer the missing contexts for the Left DerivSpecs
72 3. Add the derived bindings, generating InstInfos
76 -- DerivSpec is purely local to this module
77 data DerivSpec = DS { ds_loc :: SrcSpan
81 , ds_theta :: ThetaType
85 , ds_tc_args :: [Type]
86 , ds_newtype :: Bool }
87 -- This spec implies a dfun declaration of the form
88 -- df :: forall tvs. theta => C tys
89 -- The Name is the name for the DFun we'll build
90 -- The tyvars bind all the variables in the theta
91 -- For type families, the tycon in
92 -- in ds_tys is the *family* tycon
93 -- in ds_tc, ds_tc_args is the *representation* tycon
94 -- For non-family tycons, both are the same
96 -- ds_newtype = True <=> Newtype deriving
97 -- False <=> Vanilla deriving
102 newtype instance T [a] = MkT (Tree a) deriving( C s )
104 axiom T [a] = :RTList a
105 axiom :RTList a = Tree a
107 DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
108 , ds_tc = :RTList, ds_tc_args = [a]
109 , ds_newtype = True }
112 type DerivContext = Maybe ThetaType
113 -- Nothing <=> Vanilla deriving; infer the context of the instance decl
114 -- Just theta <=> Standalone deriving: context supplied by programmer
116 type EarlyDerivSpec = Either DerivSpec DerivSpec
117 -- Left ds => the context for the instance should be inferred
118 -- In this case ds_theta is the list of all the
119 -- constraints needed, such as (Eq [a], Eq a)
120 -- The inference process is to reduce this to a
121 -- simpler form (e.g. Eq a)
123 -- Right ds => the exact context for the instance is supplied
124 -- by the programmer; it is ds_theta
126 pprDerivSpec :: DerivSpec -> SDoc
127 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
128 ds_cls = c, ds_tys = tys, ds_theta = rhs })
129 = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
130 <+> equals <+> ppr rhs)
132 instance Outputable DerivSpec where
137 Inferring missing contexts
138 ~~~~~~~~~~~~~~~~~~~~~~~~~~
141 data T a b = C1 (Foo a) (Bar b)
146 [NOTE: See end of these comments for what to do with
147 data (C a, D b) => T a b = ...
150 We want to come up with an instance declaration of the form
152 instance (Ping a, Pong b, ...) => Eq (T a b) where
155 It is pretty easy, albeit tedious, to fill in the code "...". The
156 trick is to figure out what the context for the instance decl is,
157 namely @Ping@, @Pong@ and friends.
159 Let's call the context reqd for the T instance of class C at types
160 (a,b, ...) C (T a b). Thus:
162 Eq (T a b) = (Ping a, Pong b, ...)
164 Now we can get a (recursive) equation from the @data@ decl:
166 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
167 u Eq (T b a) u Eq Int -- From C2
168 u Eq (T a a) -- From C3
170 Foo and Bar may have explicit instances for @Eq@, in which case we can
171 just substitute for them. Alternatively, either or both may have
172 their @Eq@ instances given by @deriving@ clauses, in which case they
173 form part of the system of equations.
175 Now all we need do is simplify and solve the equations, iterating to
176 find the least fixpoint. Notice that the order of the arguments can
177 switch around, as here in the recursive calls to T.
179 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
183 Eq (T a b) = {} -- The empty set
186 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
187 u Eq (T b a) u Eq Int -- From C2
188 u Eq (T a a) -- From C3
190 After simplification:
191 = Eq a u Ping b u {} u {} u {}
196 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
197 u Eq (T b a) u Eq Int -- From C2
198 u Eq (T a a) -- From C3
200 After simplification:
205 = Eq a u Ping b u Eq b u Ping a
207 The next iteration gives the same result, so this is the fixpoint. We
208 need to make a canonical form of the RHS to ensure convergence. We do
209 this by simplifying the RHS to a form in which
211 - the classes constrain only tyvars
212 - the list is sorted by tyvar (major key) and then class (minor key)
213 - no duplicates, of course
215 So, here are the synonyms for the ``equation'' structures:
218 Note [Data decl contexts]
219 ~~~~~~~~~~~~~~~~~~~~~~~~~
222 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
224 We will need an instance decl like:
226 instance (Read a, RealFloat a) => Read (Complex a) where
229 The RealFloat in the context is because the read method for Complex is bound
230 to construct a Complex, and doing that requires that the argument type is
233 But this ain't true for Show, Eq, Ord, etc, since they don't construct
234 a Complex; they only take them apart.
236 Our approach: identify the offending classes, and add the data type
237 context to the instance decl. The "offending classes" are
241 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
242 pattern matching against a constructor from a data type with a context
243 gives rise to the constraints for that context -- or at least the thinned
244 version. So now all classes are "offending".
246 Note [Newtype deriving]
247 ~~~~~~~~~~~~~~~~~~~~~~~
251 newtype T = T Char deriving( C [a] )
253 Notice the free 'a' in the deriving. We have to fill this out to
254 newtype T = T Char deriving( forall a. C [a] )
256 And then translate it to:
257 instance C [a] Char => C [a] T where ...
260 Note [Newtype deriving superclasses]
261 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
262 (See also Trac #1220 for an interesting exchange on newtype
263 deriving and superclasses.)
265 The 'tys' here come from the partial application in the deriving
266 clause. The last arg is the new instance type.
268 We must pass the superclasses; the newtype might be an instance
269 of them in a different way than the representation type
270 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
271 Then the Show instance is not done via isomorphism; it shows
273 The Num instance is derived via isomorphism, but the Show superclass
274 dictionary must the Show instance for Foo, *not* the Show dictionary
275 gotten from the Num dictionary. So we must build a whole new dictionary
276 not just use the Num one. The instance we want is something like:
277 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
280 There may be a coercion needed which we get from the tycon for the newtype
281 when the dict is constructed in TcInstDcls.tcInstDecl2
284 Note [Unused constructors and deriving clauses]
285 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
286 See Trac #3221. Consider
287 data T = T1 | T2 deriving( Show )
288 Are T1 and T2 unused? Well, no: the deriving clause expands to mention
289 both of them. So we gather defs/uses from deriving just like anything else.
291 %************************************************************************
293 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
295 %************************************************************************
298 tcDeriving :: [LTyClDecl Name] -- All type constructors
299 -> [LInstDecl Name] -- All instance declarations
300 -> [LDerivDecl Name] -- All stand-alone deriving declarations
301 -> TcM ([InstInfo Name] -- The generated "instance decls"
302 ,HsValBinds Name -- Extra generated top-level bindings
304 ,[TyCon] -- Extra generated top-level types
305 ,[TyCon]) -- Extra generated type family instances
307 tcDeriving tycl_decls inst_decls deriv_decls
308 = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
309 do { -- Fish the "deriving"-related information out of the TcEnv
310 -- And make the necessary "equations".
311 is_boot <- tcIsHsBoot
312 ; traceTc "tcDeriving" (ppr is_boot)
313 ; (early_specs, genericsExtras)
314 <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
315 ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
317 ; overlap_flag <- getOverlapFlag
318 ; let (infer_specs, given_specs) = splitEithers early_specs
319 ; insts1 <- mapM (genInst True overlap_flag) given_specs
321 ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
322 inferInstanceContexts overlap_flag infer_specs
324 ; insts2 <- mapM (genInst False overlap_flag) final_specs
326 -- We no longer generate the old generic to/from functions
327 -- from each type declaration, so this is emptyBag
328 ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
330 ; (inst_info, rn_binds, rn_dus)
331 <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
334 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
335 (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
337 ; when (not (null inst_info)) $
338 dumpDerivingInfo (ddump_deriving inst_info rn_binds)
340 ; return ( inst_info, rn_binds, rn_dus
341 , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
343 ddump_deriving :: [InstInfo Name] -> HsValBinds Name
344 -> [MetaTyCons] -- ^ Empty data constructors
345 -> [TyCon] -- ^ Rep type family instances
346 -> [[(InstInfo RdrName, DerivAuxBinds)]]
347 -- ^ Instances for the repMetaTys
349 ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
350 = hang (ptext (sLit "Derived instances"))
351 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
353 $$ hangP "Generic representation" (
354 hangP "Generated datatypes for meta-information"
355 (vcat (map ppr repMetaTys))
356 -- The Outputable instance for TyCon unfortunately only prints the name...
357 $$ hangP "Representation types"
358 (vcat (map ppr repTyCons))
359 $$ hangP "Meta-information instances"
360 (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
362 hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
365 renameDeriv :: Bool -> LHsBinds RdrName
366 -> [(InstInfo RdrName, DerivAuxBinds)]
367 -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
368 renameDeriv is_boot gen_binds insts
369 | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
370 -- The inst-info bindings will all be empty, but it's easier to
371 -- just use rn_inst_info to change the type appropriately
372 = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
373 ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
376 = discardWarnings $ -- Discard warnings about unused bindings etc
377 do { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns
378 -- are used in the generic binds
379 rnTopBinds (ValBindsIn gen_binds [])
380 ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive
382 -- Generate and rename any extra not-one-inst-decl-specific binds,
383 -- notably "con2tag" and/or "tag2con" functions.
384 -- Bring those names into scope before renaming the instances themselves
385 ; loc <- getSrcSpanM -- Generic loc for shared bindings
386 ; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $
387 rm_dups [] $ concat deriv_aux_binds
388 aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
389 ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
390 ; bindLocalNames (collectHsValBinders rn_aux_lhs) $
391 do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
392 ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
393 ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
394 dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
397 (inst_infos, deriv_aux_binds) = unzip insts
399 -- Remove duplicate requests for auxilliary bindings
401 rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
402 | otherwise = rm_dups (b:acc) bs
405 rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
406 rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
407 = return ( info { iBinds = NewTypeDerived coi tc }
408 , mkFVs (map dataConName (tyConDataCons tc)))
409 -- See Note [Newtype deriving and unused constructors]
411 rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
412 = -- Bring the right type variables into
413 -- scope (yuk), and rename the method binds
415 bindLocalNames (map Var.varName tyvars) $
416 do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
417 ; let binds' = VanillaInst rn_binds [] standalone_deriv
418 ; return (inst_info { iBinds = binds' }, fvs) }
420 (tyvars,_, clas,_) = instanceHead inst
421 clas_nm = className clas
424 Note [Newtype deriving and unused constructors]
425 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
426 Consider this (see Trac #1954):
429 newtype P a = MkP (IO a) deriving Monad
431 If you compile with -fwarn-unused-binds you do not expect the warning
432 "Defined but not used: data consructor MkP". Yet the newtype deriving
433 code does not explicitly mention MkP, but it should behave as if you
435 instance Monad P where
436 return x = MkP (return x)
439 So we want to signal a user of the data constructor 'MkP'. That's
440 what we do in rn_inst_info, and it's the only reason we have the TyCon
441 stored in NewTypeDerived.
444 %************************************************************************
446 From HsSyn to DerivSpec
448 %************************************************************************
450 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
453 -- Make the "extras" for the generic representation
454 mkGenDerivExtras :: TyCon
455 -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
456 mkGenDerivExtras tc = do
457 { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
458 ; metaInsts <- genDtMeta (tc, metaTyCons)
459 ; return (metaTyCons, rep0TyInst, metaInsts) }
461 makeDerivSpecs :: Bool
465 -> TcM ( [EarlyDerivSpec]
466 , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
467 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
468 | is_boot -- No 'deriving' at all in hs-boot files
469 = do { mapM_ add_deriv_err deriv_locs
472 = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
473 ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
475 -- Generic representation stuff: we might need to add some "extras"
477 ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
478 ; generic_extras_deriv <- if not xDerRep
479 -- No extras if the flag is off
482 let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
483 -- Select only those types that derive Generic
484 ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
485 , getClassName c == Just genClassName ]
486 ; let sel_deriv_decls = catMaybes [ getTypeName t
487 | L _ (DerivDecl (L _ t)) <- deriv_decls
488 , getClassName t == Just genClassName ]
489 ; derTyDecls <- mapM tcLookupTyCon $
490 filter (needsExtras xDerRep
491 (sel_tydata ++ sel_deriv_decls)) allTyNames
492 -- We need to generate the extras to add to what has
493 -- already been derived
494 ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
495 pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
496 pprTrace "derTyDecls" (ppr derTyDecls) $
497 pprTrace "deriv_decls" (ppr deriv_decls) $ -}
498 mapM mkGenDerivExtras derTyDecls }
501 ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
503 -- We need extras if the flag DeriveGeneric is on and this type is
505 needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
507 -- Extracts the name of the class in the deriving
508 getClassName :: HsType Name -> Maybe Name
509 getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
510 getClassName (HsPredTy (HsClassP n _)) = Just n
511 getClassName _ = Nothing
513 -- Extracts the name of the type in the deriving
514 -- This function (and also getClassName above) is not really nice, and I
515 -- might not have covered all possible cases. I wonder if there is no easier
516 -- way to extract class and type name from a LDerivDecl...
517 getTypeName :: HsType Name -> Maybe Name
518 getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n
519 getTypeName (HsTyVar n) = Just n
520 getTypeName (HsOpTy _ (L _ n) _) = Just n
521 getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
522 getTypeName (HsAppTy (L _ n) _) = getTypeName n
523 getTypeName (HsParTy (L _ n)) = getTypeName n
524 getTypeName (HsKindSig (L _ n) _) = getTypeName n
525 getTypeName _ = Nothing
527 extractTyDataPreds decls
528 = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
530 all_tydata :: [(LHsType Name, LTyClDecl Name)]
531 -- Derived predicate paired with its data type declaration
532 all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
534 deriv_locs = map (getLoc . snd) all_tydata
535 ++ map getLoc deriv_decls
537 add_deriv_err loc = setSrcSpan loc $
538 addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
539 2 (ptext (sLit "Use an instance declaration instead")))
541 ------------------------------------------------------------------
542 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
543 -- Standalone deriving declarations
544 -- e.g. deriving instance Show a => Show (T a)
545 -- Rather like tcLocalInstDecl
546 deriveStandalone (L loc (DerivDecl deriv_ty))
548 addErrCtxt (standaloneCtxt deriv_ty) $
549 do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
550 ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty
551 ; traceTc "Standalone deriving;" $ vcat
552 [ text "tvs:" <+> ppr tvs
553 , text "theta:" <+> ppr theta
554 , text "cls:" <+> ppr cls
555 , text "tys:" <+> ppr inst_tys ]
556 ; checkValidInstance deriv_ty tvs theta cls inst_tys
557 -- C.f. TcInstDcls.tcLocalInstDecl1
559 ; let cls_tys = take (length inst_tys - 1) inst_tys
560 inst_ty = last inst_tys
561 ; traceTc "Standalone deriving:" $ vcat
562 [ text "class:" <+> ppr cls
563 , text "class types:" <+> ppr cls_tys
564 , text "type:" <+> ppr inst_ty ]
565 ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
568 ------------------------------------------------------------------
569 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
570 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
571 tcdTyVars = tv_names,
572 tcdTyPats = ty_pats }))
573 = setSrcSpan loc $ -- Use the location of the 'deriving' item
575 do { (tvs, tc, tc_args) <- get_lhs ty_pats
576 ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
577 -- the type variables for the type constructor
579 do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
580 -- The "deriv_pred" is a LHsType to take account of the fact that for
581 -- newtype deriving we allow deriving (forall a. C [a]).
583 -- Given data T a b c = ... deriving( C d ),
584 -- we want to drop type variables from T so that (C d (T a)) is well-kinded
585 ; let cls_tyvars = classTyVars cls
586 kind = tyVarKind (last cls_tyvars)
587 (arg_kinds, _) = splitKindFunTys kind
588 n_args_to_drop = length arg_kinds
589 n_args_to_keep = tyConArity tc - n_args_to_drop
590 args_to_drop = drop n_args_to_keep tc_args
591 inst_ty = mkTyConApp tc (take n_args_to_keep tc_args)
592 inst_ty_kind = typeKind inst_ty
593 dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
594 univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
595 `minusVarSet` dropped_tvs
597 -- Check that the result really is well-kinded
598 ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
599 (derivingKindErr tc cls cls_tys kind)
601 ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a)
602 tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
603 (derivingEtaErr cls cls_tys inst_ty)
605 -- (a) The data type can be eta-reduced; eg reject:
606 -- data instance T a a = ... deriving( Monad )
607 -- (b) The type class args do not mention any of the dropped type
609 -- newtype T a s = ... deriving( ST s )
611 -- Type families can't be partially applied
612 -- e.g. newtype instance T Int a = MkT [a] deriving( Monad )
613 -- Note [Deriving, type families, and partial applications]
614 ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
615 (typeFamilyPapErr tc cls cls_tys inst_ty)
617 ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
619 -- Tiresomely we must figure out the "lhs", which is awkward for type families
620 -- E.g. data T a b = .. deriving( Eq )
621 -- Here, the lhs is (T a b)
622 -- data instance TF Int b = ... deriving( Eq )
623 -- Here, the lhs is (TF Int b)
624 -- But if we just look up the tycon_name, we get is the *family*
625 -- tycon, but not pattern types -- they are in the *rep* tycon.
626 get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
627 ; let tvs = tyConTyVars tc
628 ; return (tvs, tc, mkTyVarTys tvs) }
629 get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
630 ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
631 ; let (tc, tc_args) = tcSplitTyConApp tc_app
632 ; return (tvs, tc, tc_args) }
635 = panic "derivTyData" -- Caller ensures that only TyData can happen
638 Note [Deriving, type families, and partial applications]
639 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
640 When there are no type families, it's quite easy:
642 newtype S a = MkS [a]
643 -- :CoS :: S ~ [] -- Eta-reduced
645 instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
646 instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
648 When type familes are involved it's trickier:
651 newtype instance T Int a = MkT [a] deriving( Eq, Monad )
652 -- :RT is the representation type for (T Int a)
653 -- :CoF:R1T a :: T Int a ~ :RT a -- Not eta reduced
654 -- :Co:R1T :: :RT ~ [] -- Eta-reduced
656 instance Eq [a] => Eq (T Int a) -- easy by coercion
657 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
659 The "???" bit is that we don't build the :CoF thing in eta-reduced form
660 Henc the current typeFamilyPapErr, even though the instance makes sense.
661 After all, we can write it out
662 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
667 mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
668 -> DerivContext -- Just => context supplied (standalone deriving)
669 -- Nothing => context inferred (deriving on data decl)
670 -> TcRn EarlyDerivSpec
671 -- Make the EarlyDerivSpec for an instance
672 -- forall tvs. theta => cls (tys ++ [ty])
673 -- where the 'theta' is optional (that's the Maybe part)
674 -- Assumes that this declaration is well-kinded
676 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
677 | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
678 , isAlgTyCon tycon -- Check for functions, primitive types etc
679 = mk_alg_eqn tycon tc_args
681 = failWithTc (derivingThingErr False cls cls_tys tc_app
682 (ptext (sLit "The last argument of the instance must be a data or newtype application")))
685 bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
687 mk_alg_eqn tycon tc_args
688 | className cls `elem` typeableClassNames
689 = do { dflags <- getDOpts
690 ; case checkTypeableConditions (dflags, tycon) of
691 Just err -> bale_out err
692 Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta }
694 | isDataFamilyTyCon tycon
695 , length tc_args /= tyConArity tycon
696 = bale_out (ptext (sLit "Unsaturated data family application"))
699 = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
700 -- Be careful to test rep_tc here: in the case of families,
701 -- we want to check the instance tycon, not the family tycon
703 -- For standalone deriving (mtheta /= Nothing),
704 -- check that all the data constructors are in scope.
705 ; rdr_env <- getGlobalRdrEnv
706 ; let hidden_data_cons = isAbstractTyCon rep_tc ||
707 any not_in_scope (tyConDataCons rep_tc)
708 not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
709 ; unless (isNothing mtheta || not hidden_data_cons)
710 (bale_out (derivingHiddenErr tycon))
713 ; if isDataTyCon rep_tc then
714 mkDataTypeEqn orig dflags tvs cls cls_tys
715 tycon tc_args rep_tc rep_tc_args mtheta
717 mkNewTypeEqn orig dflags tvs cls cls_tys
718 tycon tc_args rep_tc rep_tc_args mtheta }
722 %************************************************************************
726 %************************************************************************
729 mkDataTypeEqn :: CtOrigin
731 -> [Var] -- Universally quantified type variables in the instance
732 -> Class -- Class for which we need to derive an instance
733 -> [Type] -- Other parameters to the class except the last
734 -> TyCon -- Type constructor for which the instance is requested
735 -- (last parameter to the type class)
736 -> [Type] -- Parameters to the type constructor
737 -> TyCon -- rep of the above (for type families)
738 -> [Type] -- rep of the above
739 -> DerivContext -- Context of the instance, for standalone deriving
740 -> TcRn EarlyDerivSpec -- Return 'Nothing' if error
742 mkDataTypeEqn orig dflags tvs cls cls_tys
743 tycon tc_args rep_tc rep_tc_args mtheta
744 = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
745 -- NB: pass the *representation* tycon to checkSideConditions
746 CanDerive -> go_for_it
747 NonDerivableClass -> bale_out (nonStdErr cls)
748 DerivableClassError msg -> bale_out msg
750 go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
751 bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
753 mk_data_eqn :: CtOrigin -> [TyVar] -> Class
754 -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
755 -> TcM EarlyDerivSpec
756 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
757 = do { dfun_name <- new_dfun_name cls tycon
759 ; let inst_tys = [mkTyConApp tycon tc_args]
760 inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
761 spec = DS { ds_loc = loc, ds_orig = orig
762 , ds_name = dfun_name, ds_tvs = tvs
763 , ds_cls = cls, ds_tys = inst_tys
764 , ds_tc = rep_tc, ds_tc_args = rep_tc_args
765 , ds_theta = mtheta `orElse` inferred_constraints
766 , ds_newtype = False }
768 ; return (if isJust mtheta then Right spec -- Specified context
769 else Left spec) } -- Infer context
771 ----------------------
772 mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
773 -> TyCon -> [TcType] -> DerivContext
774 -> TcM EarlyDerivSpec
775 mk_typeable_eqn orig tvs cls tycon tc_args mtheta
776 -- The Typeable class is special in several ways
777 -- data T a b = ... deriving( Typeable )
779 -- instance Typeable2 T where ...
781 -- 1. There are no constraints in the instance
782 -- 2. There are no type variables either
783 -- 3. The actual class we want to generate isn't necessarily
784 -- Typeable; it depends on the arity of the type
785 | isNothing mtheta -- deriving on a data type decl
786 = do { checkTc (cls `hasKey` typeableClassKey)
787 (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
788 ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
789 ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
791 | otherwise -- standaone deriving
792 = do { checkTc (null tc_args)
793 (ptext (sLit "Derived typeable instance must be of form (Typeable")
794 <> int (tyConArity tycon) <+> ppr tycon <> rparen)
795 ; dfun_name <- new_dfun_name cls tycon
798 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
799 , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
800 , ds_tc = tycon, ds_tc_args = []
801 , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
803 ----------------------
804 inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
805 -- Generate a sufficiently large set of constraints that typechecking the
806 -- generated method definitions should succeed. This set will be simplified
807 -- before being used in the instance declaration
808 inferConstraints _ cls inst_tys rep_tc rep_tc_args
809 -- Generic constraints are easy
810 | cls `hasKey` genClassKey
812 -- The others are a bit more complicated
814 = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
815 stupid_constraints ++ extra_constraints
816 ++ sc_constraints ++ con_arg_constraints
818 -- Constraints arising from the arguments of each constructor
820 = [ mkClassPred cls [arg_ty]
821 | data_con <- tyConDataCons rep_tc,
822 arg_ty <- ASSERT( isVanillaDataCon data_con )
823 get_constrained_tys $
824 dataConInstOrigArgTys data_con all_rep_tc_args,
825 not (isUnLiftedType arg_ty) ]
826 -- No constraints for unlifted types
827 -- Where they are legal we generate specilised function calls
829 -- For functor-like classes, two things are different
830 -- (a) We recurse over argument types to generate constraints
831 -- See Functor examples in TcGenDeriv
832 -- (b) The rep_tc_args will be one short
833 is_functor_like = getUnique cls `elem` functorLikeClassKeys
835 get_constrained_tys :: [Type] -> [Type]
836 get_constrained_tys tys
837 | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
840 rep_tc_tvs = tyConTyVars rep_tc
841 last_tv = last rep_tc_tvs
842 all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
843 | otherwise = rep_tc_args
845 -- Constraints arising from superclasses
846 -- See Note [Superclasses of derived instance]
847 sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
850 -- Stupid constraints
851 stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
852 subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
854 -- Extra Data constraints
855 -- The Data class (only) requires that for
856 -- instance (...) => Data (T t1 t2)
858 -- THEN (Data t1, Data t2) are among the (...) constraints
859 -- Reason: when the IF holds, we generate a method
860 -- dataCast2 f = gcast2 f
861 -- and we need the Data constraints to typecheck the method
863 | cls `hasKey` dataClassKey
864 , all (isLiftedTypeKind . typeKind) rep_tc_args
865 = [mkClassPred cls [ty] | ty <- rep_tc_args]
869 ------------------------------------------------------------------
870 -- Check side conditions that dis-allow derivability for particular classes
871 -- This is *apart* from the newtype-deriving mechanism
873 -- Here we get the representation tycon in case of family instances as it has
874 -- the data constructors - but we need to be careful to fall back to the
875 -- family tycon (with indexes) in error messages.
877 data DerivStatus = CanDerive
878 | DerivableClassError SDoc -- Standard class, but can't do it
879 | NonDerivableClass -- Non-standard class
881 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus
882 checkSideConditions dflags mtheta cls cls_tys rep_tc
883 | Just cond <- sideConditions mtheta cls
884 = case (cond (dflags, rep_tc)) of
885 Just err -> DerivableClassError err -- Class-specific error
886 Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so
887 -- cls_tys (the type args other than last)
889 | otherwise -> DerivableClassError ty_args_why -- e.g. deriving( Eq s )
890 | otherwise = NonDerivableClass -- Not a standard class
892 ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
894 checkTypeableConditions :: Condition
895 checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
897 nonStdErr :: Class -> SDoc
898 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
900 sideConditions :: DerivContext -> Class -> Maybe Condition
901 sideConditions mtheta cls
902 | cls_key == eqClassKey = Just cond_std
903 | cls_key == ordClassKey = Just cond_std
904 | cls_key == showClassKey = Just cond_std
905 | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
906 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
907 | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
908 | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
909 | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond`
910 cond_std `andCond` cond_noUnliftedArgs)
911 | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond`
912 cond_functorOK True) -- NB: no cond_std!
913 | cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond`
914 cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
915 | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
916 cond_functorOK False)
917 | cls_key == genClassKey = Just (cond_RepresentableOk `andCond`
918 checkFlag Opt_DeriveGeneric)
919 | otherwise = Nothing
921 cls_key = getUnique cls
922 cond_std = cond_stdOK mtheta
924 type Condition = (DynFlags, TyCon) -> Maybe SDoc
925 -- first Bool is whether or not we are allowed to derive Data and Typeable
926 -- second Bool is whether or not we are allowed to derive Functor
927 -- TyCon is the *representation* tycon if the
928 -- data type is an indexed one
931 orCond :: Condition -> Condition -> Condition
934 Nothing -> Nothing -- c1 succeeds
935 Just x -> case c2 tc of -- c1 fails
937 Just y -> Just (x $$ ptext (sLit " or") $$ y)
940 andCond :: Condition -> Condition -> Condition
941 andCond c1 c2 tc = case c1 tc of
942 Nothing -> c2 tc -- c1 succeeds
943 Just x -> Just x -- c1 fails
945 cond_stdOK :: DerivContext -> Condition
946 cond_stdOK (Just _) _
947 = Nothing -- Don't check these conservative conditions for
948 -- standalone deriving; just generate the code
949 -- and let the typechecker handle the result
950 cond_stdOK Nothing (_, rep_tc)
951 | null data_cons = Just (no_cons_why rep_tc $$ suggestion)
952 | not (null con_whys) = Just (vcat con_whys $$ suggestion)
953 | otherwise = Nothing
955 suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
956 data_cons = tyConDataCons rep_tc
957 con_whys = mapCatMaybes check_con data_cons
959 check_con :: DataCon -> Maybe SDoc
961 | isVanillaDataCon con
962 , all isTauTy (dataConOrigArgTys con) = Nothing
963 | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
965 no_cons_why :: TyCon -> SDoc
966 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
967 ptext (sLit "must have at least one data constructor")
969 cond_RepresentableOk :: Condition
970 cond_RepresentableOk (_,t) = canDoGenerics t
972 cond_enumOrProduct :: Condition
973 cond_enumOrProduct = cond_isEnumeration `orCond`
974 (cond_isProduct `andCond` cond_noUnliftedArgs)
976 cond_noUnliftedArgs :: Condition
977 -- For some classes (eg Eq, Ord) we allow unlifted arg types
978 -- by generating specilaised code. For others (eg Data) we don't.
979 cond_noUnliftedArgs (_, tc)
980 | null bad_cons = Nothing
981 | otherwise = Just why
983 bad_cons = [ con | con <- tyConDataCons tc
984 , any isUnLiftedType (dataConOrigArgTys con) ]
985 why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
987 cond_isEnumeration :: Condition
988 cond_isEnumeration (_, rep_tc)
989 | isEnumerationTyCon rep_tc = Nothing
990 | otherwise = Just why
992 why = sep [ quotes (pprSourceTyCon rep_tc) <+>
993 ptext (sLit "must be an enumeration type")
994 , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
995 -- See Note [Enumeration types] in TyCon
997 cond_isProduct :: Condition
998 cond_isProduct (_, rep_tc)
999 | isProductTyCon rep_tc = Nothing
1000 | otherwise = Just why
1002 why = quotes (pprSourceTyCon rep_tc) <+>
1003 ptext (sLit "must have precisely one constructor")
1005 cond_typeableOK :: Condition
1006 -- OK for Typeable class
1007 -- Currently: (a) args all of kind *
1008 -- (b) 7 or fewer args
1009 cond_typeableOK (_, tc)
1010 | tyConArity tc > 7 = Just too_many
1011 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc))
1013 | otherwise = Nothing
1015 too_many = quotes (pprSourceTyCon tc) <+>
1016 ptext (sLit "must have 7 or fewer arguments")
1017 bad_kind = quotes (pprSourceTyCon tc) <+>
1018 ptext (sLit "must only have arguments of kind `*'")
1020 functorLikeClassKeys :: [Unique]
1021 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
1023 cond_functorOK :: Bool -> Condition
1024 -- OK for Functor/Foldable/Traversable class
1025 -- Currently: (a) at least one argument
1026 -- (b) don't use argument contravariantly
1027 -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
1028 -- (d) optionally: don't use function types
1029 -- (e) no "stupid context" on data type
1030 cond_functorOK allowFunctions (_, rep_tc)
1032 = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1033 <+> ptext (sLit "must have some type parameters"))
1035 | not (null bad_stupid_theta)
1036 = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1037 <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
1040 = msum (map check_con data_cons) -- msum picks the first 'Just', if any
1042 tc_tvs = tyConTyVars rep_tc
1043 Just (_, last_tv) = snocView tc_tvs
1044 bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc)
1045 is_bad pred = last_tv `elemVarSet` tyVarsOfPred pred
1047 data_cons = tyConDataCons rep_tc
1048 check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
1050 check_vanilla :: DataCon -> Maybe SDoc
1051 check_vanilla con | isVanillaDataCon con = Nothing
1052 | otherwise = Just (badCon con existential)
1054 ft_check :: DataCon -> FFoldType (Maybe SDoc)
1055 ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
1056 , ft_co_var = Just (badCon con covariant)
1057 , ft_fun = \x y -> if allowFunctions then x `mplus` y
1058 else Just (badCon con functions)
1059 , ft_tup = \_ xs -> msum xs
1060 , ft_ty_app = \_ x -> x
1061 , ft_bad_app = Just (badCon con wrong_arg)
1062 , ft_forall = \_ x -> x }
1064 existential = ptext (sLit "must not have existential arguments")
1065 covariant = ptext (sLit "must not use the type variable in a function argument")
1066 functions = ptext (sLit "must not contain function types")
1067 wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last")
1069 checkFlag :: ExtensionFlag -> Condition
1070 checkFlag flag (dflags, _)
1071 | xopt flag dflags = Nothing
1072 | otherwise = Just why
1074 why = ptext (sLit "You need -X") <> text flag_str
1075 <+> ptext (sLit "to derive an instance for this class")
1076 flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
1078 other -> pprPanic "checkFlag" (ppr other)
1080 std_class_via_iso :: Class -> Bool
1081 -- These standard classes can be derived for a newtype
1082 -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
1083 -- because giving so gives the same results as generating the boilerplate
1084 std_class_via_iso clas
1085 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
1086 -- Not Read/Show because they respect the type
1087 -- Not Enum, because newtypes are never in Enum
1090 non_iso_class :: Class -> Bool
1091 -- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
1092 -- even with -XGeneralizedNewtypeDeriving
1094 = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
1095 , genClassKey] ++ typeableClassKeys)
1097 typeableClassKeys :: [Unique]
1098 typeableClassKeys = map getUnique typeableClassNames
1100 new_dfun_name :: Class -> TyCon -> TcM Name
1101 new_dfun_name clas tycon -- Just a simple wrapper
1102 = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon
1103 ; newDFunName clas [mkTyConApp tycon []] loc }
1104 -- The type passed to newDFunName is only used to generate
1105 -- a suitable string; hence the empty type arg list
1107 badCon :: DataCon -> SDoc -> SDoc
1108 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1111 Note [Superclasses of derived instance]
1112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1113 In general, a derived instance decl needs the superclasses of the derived
1114 class too. So if we have
1115 data T a = ...deriving( Ord )
1116 then the initial context for Ord (T a) should include Eq (T a). Often this is
1117 redundant; we'll also generate an Ord constraint for each constructor argument,
1118 and that will probably generate enough constraints to make the Eq (T a) constraint
1119 be satisfied too. But not always; consider:
1125 data T a = MkT (S a) deriving( Ord )
1126 instance Num a => Eq (T a)
1128 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1130 data T a = MkT deriving( Data, Typeable )
1131 Here there *is* no argument field, but we must nevertheless generate
1132 a context for the Data instances:
1133 instance Typable a => Data (T a) where ...
1136 %************************************************************************
1140 %************************************************************************
1143 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1144 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1146 -> TcRn EarlyDerivSpec
1147 mkNewTypeEqn orig dflags tvs
1148 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1149 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1150 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1151 = do { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1152 ; dfun_name <- new_dfun_name cls tycon
1153 ; loc <- getSrcSpanM
1154 ; let spec = DS { ds_loc = loc, ds_orig = orig
1155 , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
1156 , ds_cls = cls, ds_tys = inst_tys
1157 , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1158 , ds_theta = mtheta `orElse` all_preds
1159 , ds_newtype = True }
1160 ; return (if isJust mtheta then Right spec
1164 = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1165 CanDerive -> go_for_it -- Use the standard H98 method
1166 DerivableClassError msg -- Error with standard class
1167 | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
1168 | otherwise -> bale_out msg
1169 NonDerivableClass -- Must use newtype deriving
1170 | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
1171 | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1172 | otherwise -> bale_out non_std
1174 newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1175 go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1176 bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1178 non_std = nonStdErr cls
1179 suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1181 -- Here is the plan for newtype derivings. We see
1182 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1183 -- where t is a type,
1184 -- ak+1...an is a suffix of a1..an, and are all tyars
1185 -- ak+1...an do not occur free in t, nor in the s1..sm
1186 -- (C s1 ... sm) is a *partial applications* of class C
1187 -- with the last parameter missing
1188 -- (T a1 .. ak) matches the kind of C's last argument
1189 -- (and hence so does t)
1190 -- The latter kind-check has been done by deriveTyData already,
1191 -- and tc_args are already trimmed
1193 -- We generate the instance
1194 -- instance forall ({a1..ak} u fvs(s1..sm)).
1195 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
1196 -- where T a1...ap is the partial application of
1197 -- the LHS of the correct kind and p >= k
1199 -- NB: the variables below are:
1200 -- tc_tvs = [a1, ..., an]
1201 -- tyvars_to_keep = [a1, ..., ak]
1202 -- rep_ty = t ak .. an
1203 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
1204 -- tys = [s1, ..., sm]
1207 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1208 -- We generate the instance
1209 -- instance Monad (ST s) => Monad (T s) where
1211 nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1212 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1213 -- eta-reduces the representation type, so we know that
1215 -- That's convenient here, because we may have to apply
1216 -- it to fewer than its original complement of arguments
1218 -- Note [Newtype representation]
1219 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1220 -- Need newTyConRhs (*not* a recursive representation finder)
1221 -- to get the representation type. For example
1222 -- newtype B = MkB Int
1223 -- newtype A = MkA B deriving( Num )
1224 -- We want the Num instance of B, *not* the Num instance of Int,
1225 -- when making the Num instance of A!
1226 rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1227 rep_tys = cls_tys ++ [rep_inst_ty]
1228 rep_pred = mkClassPred cls rep_tys
1229 -- rep_pred is the representation dictionary, from where
1230 -- we are gong to get all the methods for the newtype
1234 -- Next we figure out what superclass dictionaries to use
1235 -- See Note [Newtype deriving superclasses] above
1237 cls_tyvars = classTyVars cls
1238 dfun_tvs = tyVarsOfTypes inst_tys
1239 inst_ty = mkTyConApp tycon tc_args
1240 inst_tys = cls_tys ++ [inst_ty]
1241 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1244 -- If there are no tyvars, there's no need
1245 -- to abstract over the dictionaries we need
1246 -- Example: newtype T = MkT Int deriving( C )
1247 -- We get the derived instance
1250 -- instance C Int => C T
1251 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
1253 -------------------------------------------------------------------
1254 -- Figuring out whether we can only do this newtype-deriving thing
1256 can_derive_via_isomorphism
1257 = not (non_iso_class cls)
1261 -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
1263 arity_ok = length cls_tys + 1 == classArity cls
1264 -- Well kinded; eg not: newtype T ... deriving( ST )
1265 -- because ST needs *2* type params
1267 -- Check that eta reduction is OK
1268 eta_ok = nt_eta_arity <= length rep_tc_args
1269 -- The newtype can be eta-reduced to match the number
1270 -- of type argument actually supplied
1271 -- newtype T a b = MkT (S [a] b) deriving( Monad )
1272 -- Here the 'b' must be the same in the rep type (S [a] b)
1273 -- And the [a] must not mention 'b'. That's all handled
1276 ats_ok = null (classATs cls)
1277 -- No associated types for the class, because we don't
1278 -- currently generate type 'instance' decls; and cannot do
1279 -- so for 'data' instance decls
1282 = vcat [ ppUnless arity_ok arity_msg
1283 , ppUnless eta_ok eta_msg
1284 , ppUnless ats_ok ats_msg ]
1285 arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1286 eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
1287 ats_msg = ptext (sLit "the class has associated types")
1290 Note [Recursive newtypes]
1291 ~~~~~~~~~~~~~~~~~~~~~~~~~
1292 Newtype deriving works fine, even if the newtype is recursive.
1293 e.g. newtype S1 = S1 [T1 ()]
1294 newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1295 Remember, too, that type families are curretly (conservatively) given
1296 a recursive flag, so this also allows newtype deriving to work
1299 We used to exclude recursive types, because we had a rather simple
1300 minded way of generating the instance decl:
1302 instance Eq [A] => Eq A -- Makes typechecker loop!
1303 But now we require a simple context, so it's ok.
1306 %************************************************************************
1308 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1310 %************************************************************************
1312 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1313 terms, which is the final correct RHS for the corresponding original
1317 Each (k,TyVarTy tv) in a solution constrains only a type
1321 The (k,TyVarTy tv) pairs in a solution are canonically
1322 ordered by sorting on type varible, tv, (major key) and then class, k,
1327 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1329 inferInstanceContexts _ [] = return []
1331 inferInstanceContexts oflag infer_specs
1332 = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1333 ; iterate_deriv 1 initial_solutions }
1335 ------------------------------------------------------------------
1336 -- The initial solutions for the equations claim that each
1337 -- instance has an empty context; this solution is certainly
1338 -- in canonical form.
1339 initial_solutions :: [ThetaType]
1340 initial_solutions = [ [] | _ <- infer_specs ]
1342 ------------------------------------------------------------------
1343 -- iterate_deriv calculates the next batch of solutions,
1344 -- compares it with the current one; finishes if they are the
1345 -- same, otherwise recurses with the new solutions.
1346 -- It fails if any iteration fails
1347 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1348 iterate_deriv n current_solns
1349 | n > 20 -- Looks as if we are in an infinite loop
1350 -- This can happen if we have -XUndecidableInstances
1351 -- (See TcSimplify.tcSimplifyDeriv.)
1352 = pprPanic "solveDerivEqns: probable loop"
1353 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1355 = do { -- Extend the inst info from the explicit instance decls
1356 -- with the current set of solutions, and simplify each RHS
1357 let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1358 current_solns infer_specs
1359 ; new_solns <- checkNoErrs $
1360 extendLocalInstEnv inst_specs $
1361 mapM gen_soln infer_specs
1363 ; if (current_solns == new_solns) then
1364 return [ spec { ds_theta = soln }
1365 | (spec, soln) <- zip infer_specs current_solns ]
1367 iterate_deriv (n+1) new_solns }
1369 ------------------------------------------------------------------
1370 gen_soln :: DerivSpec -> TcM [PredType]
1371 gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1372 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1374 addErrCtxt (derivInstCtxt the_pred) $
1375 do { -- Check for a bizarre corner case, when the derived instance decl should
1376 -- have form instance C a b => D (T a) where ...
1377 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1378 -- of problems; in particular, it's hard to compare solutions for
1379 -- equality when finding the fixpoint. Moreover, simplifyDeriv
1380 -- has an assert failure because it finds a TyVar when it expects
1381 -- only TcTyVars. So I just rule it out for now. I'm not
1382 -- even sure how it can arise.
1384 ; let tv_set = mkVarSet tyvars
1385 weird_preds = [pred | pred <- deriv_rhs
1386 , not (tyVarsOfPred pred `subVarSet` tv_set)]
1387 ; mapM_ (addErrTc . badDerivedPred) weird_preds
1389 ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
1390 -- checkValidInstance tyvars theta clas inst_tys
1391 -- Not necessary; see Note [Exotic derived instance contexts]
1394 ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1395 -- Claim: the result instance declaration is guaranteed valid
1396 -- Hence no need to call:
1397 -- checkValidInstance tyvars theta clas inst_tys
1398 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
1400 the_pred = mkClassPred clas inst_tys
1402 ------------------------------------------------------------------
1403 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1404 mkInstance overlap_flag theta
1405 (DS { ds_name = dfun_name
1406 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1407 = mkLocalInstance dfun overlap_flag
1409 dfun = mkDictFunId dfun_name tyvars theta clas tys
1412 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1413 -- Add new locally-defined instances; don't bother to check
1414 -- for functional dependency errors -- that'll happen in TcInstDcls
1415 extendLocalInstEnv dfuns thing_inside
1416 = do { env <- getGblEnv
1417 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1418 env' = env { tcg_inst_env = inst_env' }
1419 ; setGblEnv env' thing_inside }
1423 %************************************************************************
1425 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1427 %************************************************************************
1429 After all the trouble to figure out the required context for the
1430 derived instance declarations, all that's left is to chug along to
1431 produce them. They will then be shoved into @tcInstDecls2@, which
1432 will do all its usual business.
1434 There are lots of possibilities for code to generate. Here are
1435 various general remarks.
1440 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1441 ``you-couldn't-do-better-by-hand'' efficient.
1444 Deriving @Show@---also pretty common--- should also be reasonable good code.
1447 Deriving for the other classes isn't that common or that big a deal.
1454 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1457 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1460 We {\em normally} generate code only for the non-defaulted methods;
1461 there are some exceptions for @Eq@ and (especially) @Ord@...
1464 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1465 constructor's numeric (@Int#@) tag. These are generated by
1466 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1467 these is around is given by @hasCon2TagFun@.
1469 The examples under the different sections below will make this
1473 Much less often (really just for deriving @Ix@), we use a
1474 @_tag2con_<tycon>@ function. See the examples.
1477 We use the renamer!!! Reason: we're supposed to be
1478 producing @LHsBinds Name@ for the methods, but that means
1479 producing correctly-uniquified code on the fly. This is entirely
1480 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1481 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1482 the renamer. What a great hack!
1486 -- Generate the InstInfo for the required instance paired with the
1487 -- *representation* tycon for that instance,
1488 -- plus any auxiliary bindings required
1490 -- Representation tycons differ from the tycon in the instance signature in
1491 -- case of instances for indexed families.
1493 genInst :: Bool -- True <=> standalone deriving
1495 -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1496 genInst standalone_deriv oflag
1497 spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1498 , ds_theta = theta, ds_newtype = is_newtype
1499 , ds_name = name, ds_cls = clas })
1501 = return (InstInfo { iSpec = inst_spec
1502 , iBinds = NewTypeDerived co rep_tycon }, [])
1505 = do { fix_env <- getFixityEnv
1506 ; let loc = getSrcSpan name
1507 (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1508 -- In case of a family instance, we need to use the representation
1509 -- tycon (after all, it has the data constructors)
1511 ; return (InstInfo { iSpec = inst_spec
1512 , iBinds = VanillaInst meth_binds [] standalone_deriv }
1515 inst_spec = mkInstance oflag theta spec
1516 co1 = case tyConFamilyCoercion_maybe rep_tycon of
1517 Just co_con -> mkAxInstCo co_con rep_tc_args
1519 -- Not a family => rep_tycon = main tycon
1520 co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
1521 co = co1 `mkTransCo` co2
1522 id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
1524 -- Example: newtype instance N [a] = N1 (Tree a)
1525 -- deriving instance Eq b => Eq (N [(b,b)])
1526 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1527 -- When dealing with the deriving clause
1528 -- co1 : N [(b,b)] ~ R1:N (b,b)
1529 -- co2 : R1:N (b,b) ~ Tree (b,b)
1530 -- co : N [(b,b)] ~ Tree (b,b)
1532 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1533 genDerivBinds loc fix_env clas tycon
1534 | className clas `elem` typeableClassNames
1535 = (gen_Typeable_binds loc tycon, [])
1538 = case assocMaybe gen_list (getUnique clas) of
1539 Just gen_fn -> gen_fn loc tycon
1540 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1542 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1543 gen_list = [(eqClassKey, gen_Eq_binds)
1544 ,(ordClassKey, gen_Ord_binds)
1545 ,(enumClassKey, gen_Enum_binds)
1546 ,(boundedClassKey, gen_Bounded_binds)
1547 ,(ixClassKey, gen_Ix_binds)
1548 ,(showClassKey, gen_Show_binds fix_env)
1549 ,(readClassKey, gen_Read_binds fix_env)
1550 ,(dataClassKey, gen_Data_binds)
1551 ,(functorClassKey, gen_Functor_binds)
1552 ,(foldableClassKey, gen_Foldable_binds)
1553 ,(traversableClassKey, gen_Traversable_binds)
1554 ,(genClassKey, genGenericBinds)
1558 %************************************************************************
1560 \subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
1562 %************************************************************************
1564 For the generic representation we need to generate:
1566 \item A Generic instance
1567 \item A Rep type instance
1568 \item Many auxiliary datatypes and instances for them (for the meta-information)
1571 @genGenericBinds@ does (1)
1572 @genGenericRepExtras@ does (2) and (3)
1573 @genGenericAll@ does all of them
1576 genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1577 genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
1579 genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
1580 genGenericRepExtras tc =
1581 do uniqS <- newUniqueSupply
1583 -- Uniques for everyone
1584 (uniqD:uniqs) = uniqsFromSupply uniqS
1585 (uniqsC,us) = splitAt (length tc_cons) uniqs
1586 uniqsS :: [[Unique]] -- Unique supply for the S datatypes
1587 uniqsS = mkUniqsS tc_arits us
1589 mkUniqsS (n:t) us = case splitAt n us of
1590 (us1,us2) -> us1 : mkUniqsS t us2
1592 tc_name = tyConName tc
1593 tc_cons = tyConDataCons tc
1594 tc_arits = map dataConSourceArity tc_cons
1596 tc_occ = nameOccName tc_name
1597 d_occ = mkGenD tc_occ
1598 c_occ m = mkGenC tc_occ m
1599 s_occ m n = mkGenS tc_occ m n
1600 mod_name = nameModule (tyConName tc)
1601 d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
1602 c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
1603 | (u,m) <- zip uniqsC [0..] ]
1604 s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
1605 | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
1607 mkTyCon name = ASSERT( isExternalName name )
1608 buildAlgTyCon name [] [] mkAbstractTyConRhs
1609 NonRecursive False NoParentTyCon Nothing
1611 metaDTyCon <- mkTyCon d_name
1612 metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
1613 metaSTyCons <- mapM sequence
1615 | s_name <- s_namesC ] | s_namesC <- s_names ]
1617 let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
1619 rep0_tycon <- tc_mkRepTyCon tc metaDts
1621 -- pprTrace "rep0" (ppr rep0_tycon) $
1622 return (metaDts, rep0_tycon)
1624 genGenericAll :: TyCon
1625 -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
1627 do (metaDts, rep0_tycon) <- genGenericRepExtras tc
1628 clas <- tcLookupClass genClassName
1629 dfun_name <- new_dfun_name clas tc
1631 mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
1632 , [ {- No DerivAuxBinds -} ])
1633 inst = mkLocalInstance dfun NoOverlap
1634 binds = VanillaInst (mkBindsRep tc) [] False
1636 tvs = tyConTyVars tc
1637 tc_ty = mkTyConApp tc (mkTyVarTys tvs)
1639 dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
1640 return (mkInstRep, metaDts, rep0_tycon)
1642 genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
1643 genDtMeta (tc,metaDts) =
1644 do dClas <- tcLookupClass datatypeClassName
1645 d_dfun_name <- new_dfun_name dClas tc
1646 cClas <- tcLookupClass constructorClassName
1647 c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
1648 sClas <- tcLookupClass selectorClassName
1649 s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
1651 | x <- metaS metaDts ])
1652 fix_env <- getFixityEnv
1655 (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
1658 d_metaTycon = metaD metaDts
1659 d_inst = mkLocalInstance d_dfun NoOverlap
1660 d_binds = VanillaInst dBinds [] False
1661 d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
1662 [ mkTyConTy d_metaTycon ]
1663 d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
1666 c_metaTycons = metaC metaDts
1667 c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap
1668 | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
1669 c_binds = [ VanillaInst c [] False | c <- cBinds ]
1670 c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
1672 c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, [])
1673 | (is,bs) <- myZip1 c_insts c_binds ]
1676 s_metaTycons = metaS metaDts
1677 s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap))
1678 (myZip2 s_metaTycons s_dfun_names)
1679 s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
1680 s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
1682 s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
1683 (myZip2 s_insts s_binds)
1685 myZip1 :: [a] -> [b] -> [(a,b)]
1686 myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
1688 myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
1690 ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
1691 [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
1693 return (d_mkInst : c_mkInst ++ concat s_mkInst)
1697 %************************************************************************
1699 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1701 %************************************************************************
1704 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1705 derivingKindErr tc cls cls_tys cls_kind
1706 = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1707 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1708 2 (ptext (sLit "Class") <+> quotes (ppr cls)
1709 <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1711 derivingEtaErr :: Class -> [Type] -> Type -> Message
1712 derivingEtaErr cls cls_tys inst_ty
1713 = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1714 nest 2 (ptext (sLit "instance (...) =>")
1715 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1717 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1718 typeFamilyPapErr tc cls cls_tys inst_ty
1719 = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1720 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1722 derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message
1723 derivingThingErr newtype_deriving clas tys ty why
1724 = sep [(hang (ptext (sLit "Can't make a derived instance of"))
1725 2 (quotes (ppr pred))
1726 $$ nest 2 extra) <> colon,
1729 extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
1731 pred = mkClassPred clas (tys ++ [ty])
1733 derivingHiddenErr :: TyCon -> SDoc
1734 derivingHiddenErr tc
1735 = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1736 2 (ptext (sLit "so you cannot derive an instance for it"))
1738 standaloneCtxt :: LHsType Name -> SDoc
1739 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1742 derivInstCtxt :: PredType -> Message
1744 = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
1746 badDerivedPred :: PredType -> Message
1748 = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1749 ptext (sLit "type variables that are not data type parameters"),
1750 nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]