Define ListSetOps.getNth, and use it
[ghc.git] / compiler / typecheck / TcDeriv.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Handles @deriving@ clauses on @data@ declarations.
7
8 \begin{code}
9 module TcDeriv ( tcDeriving ) where
10
11 #include "HsVersions.h"
12
13 import HsSyn
14 import DynFlags
15
16 import TcRnMonad
17 import FamInst
18 import TcEnv
19 import TcTyClsDecls( tcFamTyPats, tcAddFamInstCtxt )
20 import TcClassDcl( tcAddDeclCtxt )      -- Small helper
21 import TcGenDeriv                       -- Deriv stuff
22 import TcGenGenerics
23 import InstEnv
24 import Inst
25 import FamInstEnv
26 import TcHsType
27 import TcMType
28 import TcSimplify
29 import TcEvidence
30
31 import RnBinds
32 import RnEnv
33 import RnSource   ( addTcgDUs )
34 import HscTypes
35
36 import Class
37 import Type
38 import ErrUtils
39 import MkId
40 import DataCon
41 import Maybes
42 import RdrName
43 import Name
44 import NameSet
45 import TyCon
46 import TcType
47 import Var
48 import VarSet
49 import PrelNames
50 import SrcLoc
51 import Util
52 import ListSetOps
53 import Outputable
54 import FastString
55 import Bag
56
57 import Control.Monad
58 import Data.List
59 \end{code}
60
61 %************************************************************************
62 %*                                                                      *
63                 Overview
64 %*                                                                      *
65 %************************************************************************
66
67 Overall plan
68 ~~~~~~~~~~~~
69 1.  Convert the decls (i.e. data/newtype deriving clauses,
70     plus standalone deriving) to [EarlyDerivSpec]
71
72 2.  Infer the missing contexts for the Left DerivSpecs
73
74 3.  Add the derived bindings, generating InstInfos
75
76
77 \begin{code}
78 -- DerivSpec is purely  local to this module
79 data DerivSpec  = DS { ds_loc     :: SrcSpan
80                      , ds_orig    :: CtOrigin
81                      , ds_name    :: Name
82                      , ds_tvs     :: [TyVar]
83                      , ds_theta   :: ThetaType
84                      , ds_cls     :: Class
85                      , ds_tys     :: [Type]
86                      , ds_tc      :: TyCon
87                      , ds_tc_args :: [Type]
88                      , ds_newtype :: Bool }
89         -- This spec implies a dfun declaration of the form
90         --       df :: forall tvs. theta => C tys
91         -- The Name is the name for the DFun we'll build
92         -- The tyvars bind all the variables in the theta
93         -- For type families, the tycon in
94         --       in ds_tys is the *family* tycon
95         --       in ds_tc, ds_tc_args is the *representation* tycon
96         -- For non-family tycons, both are the same
97
98         -- ds_newtype = True  <=> Newtype deriving
99         --              False <=> Vanilla deriving
100 \end{code}
101
102 Example:
103
104      newtype instance T [a] = MkT (Tree a) deriving( C s )
105 ==>
106      axiom T [a] = :RTList a
107      axiom :RTList a = Tree a
108
109      DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
110         , ds_tc = :RTList, ds_tc_args = [a]
111         , ds_newtype = True }
112
113 \begin{code}
114 type DerivContext = Maybe ThetaType
115    -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
116    -- Just theta <=> Standalone deriving: context supplied by programmer
117
118 type EarlyDerivSpec = Either DerivSpec DerivSpec
119         -- Left  ds => the context for the instance should be inferred
120         --             In this case ds_theta is the list of all the
121         --                constraints needed, such as (Eq [a], Eq a)
122         --                The inference process is to reduce this to a
123         --                simpler form (e.g. Eq a)
124         --
125         -- Right ds => the exact context for the instance is supplied
126         --             by the programmer; it is ds_theta
127
128 pprDerivSpec :: DerivSpec -> SDoc
129 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
130                    ds_cls = c, ds_tys = tys, ds_theta = rhs })
131   = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
132             <+> equals <+> ppr rhs)
133
134 instance Outputable DerivSpec where
135   ppr = pprDerivSpec
136 \end{code}
137
138
139 Inferring missing contexts
140 ~~~~~~~~~~~~~~~~~~~~~~~~~~
141 Consider
142
143         data T a b = C1 (Foo a) (Bar b)
144                    | C2 Int (T b a)
145                    | C3 (T a a)
146                    deriving (Eq)
147
148 [NOTE: See end of these comments for what to do with
149         data (C a, D b) => T a b = ...
150 ]
151
152 We want to come up with an instance declaration of the form
153
154         instance (Ping a, Pong b, ...) => Eq (T a b) where
155                 x == y = ...
156
157 It is pretty easy, albeit tedious, to fill in the code "...".  The
158 trick is to figure out what the context for the instance decl is,
159 namely @Ping@, @Pong@ and friends.
160
161 Let's call the context reqd for the T instance of class C at types
162 (a,b, ...)  C (T a b).  Thus:
163
164         Eq (T a b) = (Ping a, Pong b, ...)
165
166 Now we can get a (recursive) equation from the @data@ decl:
167
168         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
169                    u Eq (T b a) u Eq Int        -- From C2
170                    u Eq (T a a)                 -- From C3
171
172 Foo and Bar may have explicit instances for @Eq@, in which case we can
173 just substitute for them.  Alternatively, either or both may have
174 their @Eq@ instances given by @deriving@ clauses, in which case they
175 form part of the system of equations.
176
177 Now all we need do is simplify and solve the equations, iterating to
178 find the least fixpoint.  Notice that the order of the arguments can
179 switch around, as here in the recursive calls to T.
180
181 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
182
183 We start with:
184
185         Eq (T a b) = {}         -- The empty set
186
187 Next iteration:
188         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
189                    u Eq (T b a) u Eq Int        -- From C2
190                    u Eq (T a a)                 -- From C3
191
192         After simplification:
193                    = Eq a u Ping b u {} u {} u {}
194                    = Eq a u Ping b
195
196 Next iteration:
197
198         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
199                    u Eq (T b a) u Eq Int        -- From C2
200                    u Eq (T a a)                 -- From C3
201
202         After simplification:
203                    = Eq a u Ping b
204                    u (Eq b u Ping a)
205                    u (Eq a u Ping a)
206
207                    = Eq a u Ping b u Eq b u Ping a
208
209 The next iteration gives the same result, so this is the fixpoint.  We
210 need to make a canonical form of the RHS to ensure convergence.  We do
211 this by simplifying the RHS to a form in which
212
213         - the classes constrain only tyvars
214         - the list is sorted by tyvar (major key) and then class (minor key)
215         - no duplicates, of course
216
217 So, here are the synonyms for the ``equation'' structures:
218
219
220 Note [Data decl contexts]
221 ~~~~~~~~~~~~~~~~~~~~~~~~~
222 Consider
223
224         data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
225
226 We will need an instance decl like:
227
228         instance (Read a, RealFloat a) => Read (Complex a) where
229           ...
230
231 The RealFloat in the context is because the read method for Complex is bound
232 to construct a Complex, and doing that requires that the argument type is
233 in RealFloat.
234
235 But this ain't true for Show, Eq, Ord, etc, since they don't construct
236 a Complex; they only take them apart.
237
238 Our approach: identify the offending classes, and add the data type
239 context to the instance decl.  The "offending classes" are
240
241         Read, Enum?
242
243 FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
244 pattern matching against a constructor from a data type with a context
245 gives rise to the constraints for that context -- or at least the thinned
246 version.  So now all classes are "offending".
247
248 Note [Newtype deriving]
249 ~~~~~~~~~~~~~~~~~~~~~~~
250 Consider this:
251     class C a b
252     instance C [a] Char
253     newtype T = T Char deriving( C [a] )
254
255 Notice the free 'a' in the deriving.  We have to fill this out to
256     newtype T = T Char deriving( forall a. C [a] )
257
258 And then translate it to:
259     instance C [a] Char => C [a] T where ...
260
261
262 Note [Newtype deriving superclasses]
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264 (See also Trac #1220 for an interesting exchange on newtype
265 deriving and superclasses.)
266
267 The 'tys' here come from the partial application in the deriving
268 clause. The last arg is the new instance type.
269
270 We must pass the superclasses; the newtype might be an instance
271 of them in a different way than the representation type
272 E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
273 Then the Show instance is not done via isomorphism; it shows
274         Foo 3 as "Foo 3"
275 The Num instance is derived via isomorphism, but the Show superclass
276 dictionary must the Show instance for Foo, *not* the Show dictionary
277 gotten from the Num dictionary. So we must build a whole new dictionary
278 not just use the Num one.  The instance we want is something like:
279      instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
280         (+) = ((+)@a)
281         ...etc...
282 There may be a coercion needed which we get from the tycon for the newtype
283 when the dict is constructed in TcInstDcls.tcInstDecl2
284
285
286 Note [Unused constructors and deriving clauses]
287 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
288 See Trac #3221.  Consider
289    data T = T1 | T2 deriving( Show )
290 Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
291 both of them.  So we gather defs/uses from deriving just like anything else.
292
293 %************************************************************************
294 %*                                                                      *
295 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
296 %*                                                                      *
297 %************************************************************************
298
299 \begin{code}
300 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
301             -> [LInstDecl Name]  -- All instance declarations
302             -> [LDerivDecl Name] -- All stand-alone deriving declarations
303             -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
304 tcDeriving tycl_decls inst_decls deriv_decls
305   = recoverM (do { g <- getGblEnv
306                  ; return (g, emptyBag, emptyValBindsOut)}) $
307     do  {       -- Fish the "deriving"-related information out of the TcEnv
308                 -- And make the necessary "equations".
309           is_boot <- tcIsHsBoot
310         ; traceTc "tcDeriving" (ppr is_boot)
311         ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
312
313         -- for each type, determine the auxliary declarations that are common
314         -- to multiple derivations involving that type (e.g. Generic and
315         -- Generic1 should use the same TcGenGenerics.MetaTyCons)
316         ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map (either id id) early_specs
317
318         ; overlap_flag <- getOverlapFlag
319         ; let (infer_specs, given_specs) = splitEithers early_specs
320         ; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs
321
322         -- the stand-alone derived instances (@insts1@) are used when inferring
323         -- the contexts for "deriving" clauses' instances (@infer_specs@)
324         ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
325                            inferInstanceContexts overlap_flag infer_specs
326
327         ; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
328
329         ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
330         ; loc <- getSrcSpanM
331         ; let (binds, newTyCons, famInsts, extraInstances) =
332                 genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
333
334         ; (inst_info, rn_binds, rn_dus) <-
335             renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
336
337         ; dflags <- getDynFlags
338         ; unless (isEmptyBag inst_info) $
339             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
340                    (ddump_deriving inst_info rn_binds newTyCons famInsts))
341
342         ; let all_tycons = map ATyCon (bagToList newTyCons)
343         ; gbl_env <- tcExtendGlobalEnv all_tycons $
344                      tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
345                      tcExtendLocalFamInstEnv (bagToList famInsts) $
346                      tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
347
348         ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
349   where
350     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
351                    -> Bag TyCon    -- ^ Empty data constructors
352                    -> Bag FamInst  -- ^ Rep type family instances
353                    -> SDoc
354     ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
355       =    hang (ptext (sLit "Derived instances:"))
356               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
357                  $$ ppr extra_binds)
358         $$ hangP "Generic representation:" (
359               hangP "Generated datatypes for meta-information:"
360                (vcat (map ppr (bagToList repMetaTys)))
361            $$ hangP "Representation types:"
362                 (vcat (map pprRepTy (bagToList repFamInsts))))
363
364     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
365
366
367
368 -- As of 24 April 2012, this only shares MetaTyCons between derivations of
369 -- Generic and Generic1; thus the types and logic are quite simple.
370 type CommonAuxiliary = MetaTyCons
371 type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
372 commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff)
373 commonAuxiliaries = foldM snoc ([], emptyBag) where
374   snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
375     | getUnique cls `elem` [genClassKey, gen1ClassKey] =
376       extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
377     | otherwise = return acc
378    where extendComAux m -- don't run m if its already in the accumulator
379            | any ((rep_tycon ==) . fst) cas = return acc
380            | otherwise = do (ca, new_stuff) <- m
381                             return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
382
383
384
385 -- Prints the representable type family instance
386 pprRepTy :: FamInst -> SDoc
387 pprRepTy fi
388   = pprFamInstHdr fi <+> ptext (sLit "=") <+> ppr (coAxiomRHS (famInstAxiom fi))
389
390 renameDeriv :: Bool
391             -> [InstInfo RdrName]
392             -> Bag (LHsBind RdrName, LSig RdrName)
393             -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
394 renameDeriv is_boot inst_infos bagBinds
395   | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
396                 -- The inst-info bindings will all be empty, but it's easier to
397                 -- just use rn_inst_info to change the type appropriately
398   = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
399         ; return ( listToBag rn_inst_infos
400                  , emptyValBindsOut, usesOnly (plusFVs fvs)) }
401
402   | otherwise
403   = discardWarnings $    -- Discard warnings about unused bindings etc
404     do  {
405         -- Bring the extra deriving stuff into scope
406         -- before renaming the instances themselves
407         ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
408         ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
409         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
410         ; let bndrs = collectHsValBinders rn_aux_lhs
411         ; bindLocalNames bndrs $
412     do  { (rn_aux, dus_aux) <- rnValBindsRHS (LocalBindCtxt (mkNameSet bndrs)) rn_aux_lhs
413         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
414         ; return (listToBag rn_inst_infos, rn_aux,
415                   dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
416
417   where
418     rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
419     rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
420         = return ( info { iBinds = NewTypeDerived coi tc }
421                  , mkFVs (map dataConName (tyConDataCons tc)))
422           -- See Note [Newtype deriving and unused constructors]
423
424     rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
425         =       -- Bring the right type variables into
426                 -- scope (yuk), and rename the method binds
427            ASSERT( null sigs )
428            bindLocalNames (map Var.varName tyvars) $
429            do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
430               ; let binds' = VanillaInst rn_binds [] standalone_deriv
431               ; return (inst_info { iBinds = binds' }, fvs) }
432         where
433           (tyvars,_, clas,_) = instanceHead inst
434           clas_nm            = className clas
435 \end{code}
436
437 Note [Newtype deriving and unused constructors]
438 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
439 Consider this (see Trac #1954):
440
441   module Bug(P) where
442   newtype P a = MkP (IO a) deriving Monad
443
444 If you compile with -fwarn-unused-binds you do not expect the warning
445 "Defined but not used: data consructor MkP". Yet the newtype deriving
446 code does not explicitly mention MkP, but it should behave as if you
447 had written
448   instance Monad P where
449      return x = MkP (return x)
450      ...etc...
451
452 So we want to signal a user of the data constructor 'MkP'.  That's
453 what we do in rn_inst_info, and it's the only reason we have the TyCon
454 stored in NewTypeDerived.
455
456
457 %************************************************************************
458 %*                                                                      *
459                 From HsSyn to DerivSpec
460 %*                                                                      *
461 %************************************************************************
462
463 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
464
465 \begin{code}
466 makeDerivSpecs :: Bool
467                -> [LTyClDecl Name]
468                -> [LInstDecl Name]
469                -> [LDerivDecl Name]
470                -> TcM [EarlyDerivSpec]
471 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
472   = do  { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls
473         ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls
474         ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls
475         ; let eqns = eqns1 ++ eqns2 ++ eqns3
476         ; if is_boot then   -- No 'deriving' at all in hs-boot files
477               do { unless (null eqns) (add_deriv_err (head eqns))
478                  ; return [] }
479           else return eqns }
480   where
481     add_deriv_err eqn
482        = setSrcSpan loc $
483          addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
484                     2 (ptext (sLit "Use an instance declaration instead")))
485        where
486          loc = case eqn of  { Left ds -> ds_loc ds; Right ds -> ds_loc ds }
487
488 ------------------------------------------------------------------
489 deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
490 deriveTyDecl (L _ decl@(TyDecl { tcdLName = L _ tc_name
491                                , tcdTyDefn = TyData { td_derivs = Just preds } }))
492   = tcAddDeclCtxt decl $
493     do { tc <- tcLookupTyCon tc_name
494        ; let tvs = tyConTyVars tc
495              tys = mkTyVarTys tvs
496        ; mapM (deriveTyData tvs tc tys) preds }
497
498 deriveTyDecl _ = return []
499
500 ------------------------------------------------------------------
501 deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
502 deriveInstDecl (L _ (FamInstD { lid_inst = fam_inst }))
503   = deriveFamInst fam_inst
504 deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts }))
505   = concatMapM (deriveFamInst . unLoc) fam_insts
506
507 ------------------------------------------------------------------
508 deriveFamInst :: FamInstDecl Name -> TcM [EarlyDerivSpec]
509 deriveFamInst decl@(FamInstDecl { fid_tycon = L _ tc_name, fid_pats = pats
510                                 , fid_defn = TyData { td_derivs = Just preds } })
511   = tcAddFamInstCtxt decl $
512     do { fam_tc <- tcLookupTyCon tc_name
513        ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ ->
514          mapM (deriveTyData tvs' fam_tc pats') preds }
515         -- Tiresomely we must figure out the "lhs", which is awkward for type families
516         -- E.g.   data T a b = .. deriving( Eq )
517         --          Here, the lhs is (T a b)
518         --        data instance TF Int b = ... deriving( Eq )
519         --          Here, the lhs is (TF Int b)
520         -- But if we just look up the tycon_name, we get is the *family*
521         -- tycon, but not pattern types -- they are in the *rep* tycon.
522
523 deriveFamInst _ = return []
524
525 ------------------------------------------------------------------
526 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
527 -- Standalone deriving declarations
528 --  e.g.   deriving instance Show a => Show (T a)
529 -- Rather like tcLocalInstDecl
530 deriveStandalone (L loc (DerivDecl deriv_ty))
531   = setSrcSpan loc                   $
532     addErrCtxt (standaloneCtxt deriv_ty)  $
533     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
534        ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
535        ; traceTc "Standalone deriving;" $ vcat
536               [ text "tvs:" <+> ppr tvs
537               , text "theta:" <+> ppr theta
538               , text "cls:" <+> ppr cls
539               , text "tys:" <+> ppr inst_tys ]
540                 -- C.f. TcInstDcls.tcLocalInstDecl1
541
542        ; let cls_tys = take (length inst_tys - 1) inst_tys
543              inst_ty = last inst_tys
544        ; traceTc "Standalone deriving:" $ vcat
545               [ text "class:" <+> ppr cls
546               , text "class types:" <+> ppr cls_tys
547               , text "type:" <+> ppr inst_ty ]
548        ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
549                    (Just theta) }
550
551 ------------------------------------------------------------------
552 deriveTyData :: [TyVar] -> TyCon -> [Type]
553              -> LHsType Name           -- The deriving predicate
554              -> TcM EarlyDerivSpec
555 -- The deriving clause of a data or newtype declaration
556 deriveTyData tvs tc tc_args (L loc deriv_pred)
557   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
558     tcExtendTyVarEnv tvs $      -- Deriving preds may (now) mention
559                                 -- the type variables for the type constructor
560
561     do  { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
562                 -- The "deriv_pred" is a LHsType to take account of the fact that for
563                 -- newtype deriving we allow deriving (forall a. C [a]).
564
565         -- Given data T a b c = ... deriving( C d ),
566         -- we want to drop type variables from T so that (C d (T a)) is well-kinded
567         ; let cls_tyvars     = classTyVars cls
568               kind           = tyVarKind (last cls_tyvars)
569               (arg_kinds, _) = splitKindFunTys kind
570               n_args_to_drop = length arg_kinds
571               n_args_to_keep = tyConArity tc - n_args_to_drop
572               args_to_drop   = drop n_args_to_keep tc_args
573               inst_ty        = mkTyConApp tc (take n_args_to_keep tc_args)
574               inst_ty_kind   = typeKind inst_ty
575               dropped_tvs    = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
576               univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
577                                              `minusVarSet` dropped_tvs
578
579         ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$
580                      pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
581
582         -- Check that the result really is well-kinded
583         ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
584                   (derivingKindErr tc cls cls_tys kind)
585
586         ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop &&           -- (a)
587                    tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
588                   (derivingEtaErr cls cls_tys inst_ty)
589                 -- Check that
590                 --  (a) The data type can be eta-reduced; eg reject:
591                 --              data instance T a a = ... deriving( Monad )
592                 --  (b) The type class args do not mention any of the dropped type
593                 --      variables
594                 --              newtype T a s = ... deriving( ST s )
595
596         -- Type families can't be partially applied
597         -- e.g.   newtype instance T Int a = MkT [a] deriving( Monad )
598         -- Note [Deriving, type families, and partial applications]
599         ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
600                   (typeFamilyPapErr tc cls cls_tys inst_ty)
601
602         ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing }
603 \end{code}
604
605 Note [Deriving, type families, and partial applications]
606 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
607 When there are no type families, it's quite easy:
608
609     newtype S a = MkS [a]
610     -- :CoS :: S  ~ []  -- Eta-reduced
611
612     instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
613     instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
614
615 When type familes are involved it's trickier:
616
617     data family T a b
618     newtype instance T Int a = MkT [a] deriving( Eq, Monad )
619     -- :RT is the representation type for (T Int a)
620     --  :CoF:R1T a :: T Int a ~ :RT a   -- Not eta reduced
621     --  :Co:R1T    :: :RT ~ []          -- Eta-reduced
622
623     instance Eq [a] => Eq (T Int a)     -- easy by coercion
624     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
625
626 The "???" bit is that we don't build the :CoF thing in eta-reduced form
627 Henc the current typeFamilyPapErr, even though the instance makes sense.
628 After all, we can write it out
629     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
630       return x = MkT [x]
631       ... etc ...
632
633 \begin{code}
634 mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
635           -> DerivContext       -- Just    => context supplied (standalone deriving)
636                                 -- Nothing => context inferred (deriving on data decl)
637           -> TcRn EarlyDerivSpec
638 -- Make the EarlyDerivSpec for an instance
639 --      forall tvs. theta => cls (tys ++ [ty])
640 -- where the 'theta' is optional (that's the Maybe part)
641 -- Assumes that this declaration is well-kinded
642
643 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
644   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
645   , isAlgTyCon tycon    -- Check for functions, primitive types etc
646   = mk_alg_eqn tycon tc_args
647   | otherwise
648   = failWithTc (derivingThingErr False cls cls_tys tc_app
649                (ptext (sLit "The last argument of the instance must be a data or newtype application")))
650
651   where
652      bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
653
654      mk_alg_eqn tycon tc_args
655       | className cls `elem` typeableClassNames
656       = do { dflags <- getDynFlags
657            ; case checkTypeableConditions (dflags, tycon, tc_args) of
658                Just err -> bale_out err
659                Nothing  -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta }
660
661       | isDataFamilyTyCon tycon
662       , length tc_args /= tyConArity tycon
663       = bale_out (ptext (sLit "Unsaturated data family application"))
664
665       | otherwise
666       = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
667                   -- Be careful to test rep_tc here: in the case of families,
668                   -- we want to check the instance tycon, not the family tycon
669
670            -- For standalone deriving (mtheta /= Nothing),
671            -- check that all the data constructors are in scope.
672            ; rdr_env <- getGlobalRdrEnv
673            ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
674                                     (isAbstractTyCon rep_tc ||
675                                      any not_in_scope (tyConDataCons rep_tc))
676                  not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
677            ; unless (isNothing mtheta || not hidden_data_cons)
678                     (bale_out (derivingHiddenErr tycon))
679
680            ; dflags <- getDynFlags
681            ; if isDataTyCon rep_tc then
682                 mkDataTypeEqn orig dflags tvs cls cls_tys
683                               tycon tc_args rep_tc rep_tc_args mtheta
684              else
685                 mkNewTypeEqn orig dflags tvs cls cls_tys
686                              tycon tc_args rep_tc rep_tc_args mtheta }
687 \end{code}
688
689
690 %************************************************************************
691 %*                                                                      *
692                 Deriving data types
693 %*                                                                      *
694 %************************************************************************
695
696 \begin{code}
697 mkDataTypeEqn :: CtOrigin
698               -> DynFlags
699               -> [Var]                  -- Universally quantified type variables in the instance
700               -> Class                  -- Class for which we need to derive an instance
701               -> [Type]                 -- Other parameters to the class except the last
702               -> TyCon                  -- Type constructor for which the instance is requested
703                                         --    (last parameter to the type class)
704               -> [Type]                 -- Parameters to the type constructor
705               -> TyCon                  -- rep of the above (for type families)
706               -> [Type]                 -- rep of the above
707               -> DerivContext        -- Context of the instance, for standalone deriving
708               -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error
709
710 mkDataTypeEqn orig dflags tvs cls cls_tys
711               tycon tc_args rep_tc rep_tc_args mtheta
712   = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
713         -- NB: pass the *representation* tycon to checkSideConditions
714         CanDerive               -> go_for_it
715         NonDerivableClass       -> bale_out (nonStdErr cls)
716         DerivableClassError msg -> bale_out msg
717   where
718     go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
719     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
720
721 mk_data_eqn :: CtOrigin -> [TyVar] -> Class
722             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
723             -> TcM EarlyDerivSpec
724 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
725   = do  { loc                  <- getSrcSpanM
726         ; dfun_name            <- new_dfun_name cls tycon
727         ; inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
728         ; let spec = DS { ds_loc = loc, ds_orig = orig
729                         , ds_name = dfun_name, ds_tvs = tvs
730                         , ds_cls = cls, ds_tys = inst_tys
731                         , ds_tc = rep_tc, ds_tc_args = rep_tc_args
732                         , ds_theta =  mtheta `orElse` inferred_constraints
733                         , ds_newtype = False }
734
735         ; return (if isJust mtheta then Right spec      -- Specified context
736                                    else Left spec) }    -- Infer context
737   where
738     inst_tys = [mkTyConApp tycon tc_args]
739
740 ----------------------
741 mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
742                 -> TyCon -> [TcType] -> DerivContext
743                 -> TcM EarlyDerivSpec
744 mk_typeable_eqn orig tvs cls tycon tc_args mtheta
745         -- The Typeable class is special in several ways
746         --        data T a b = ... deriving( Typeable )
747         -- gives
748         --        instance Typeable2 T where ...
749         -- Notice that:
750         -- 1. There are no constraints in the instance
751         -- 2. There are no type variables either
752         -- 3. The actual class we want to generate isn't necessarily
753         --      Typeable; it depends on the arity of the type
754   | isNothing mtheta    -- deriving on a data type decl
755   = do  { checkTc (cls `hasKey` typeableClassKey)
756                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
757         ; real_cls <- tcLookupClass (typeableClassNames `getNth` tyConArity tycon)
758                       -- See Note [Getting base classes]
759         ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
760
761   | otherwise           -- standaone deriving
762   = do  { checkTc (null tc_args)
763                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
764                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
765         ; dfun_name <- new_dfun_name cls tycon
766         ; loc <- getSrcSpanM
767         ; return (Right $
768                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
769                      , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
770                      , ds_tc = tycon, ds_tc_args = []
771                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
772
773 ----------------------
774 inferConstraints :: Class -> [TcType]
775                  -> TyCon -> [TcType]
776                  -> TcM ThetaType
777 -- Generate a sufficiently large set of constraints that typechecking the
778 -- generated method definitions should succeed.   This set will be simplified
779 -- before being used in the instance declaration
780 inferConstraints cls inst_tys rep_tc rep_tc_args
781   | cls `hasKey` genClassKey    -- Generic constraints are easy
782   = return []
783
784   | cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
785   = ASSERT (length rep_tc_tvs > 0)   -- See Note [Getting base classes]
786     do { functorClass <- tcLookupClass functorClassName
787        ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }
788
789   | otherwise  -- The others are a bit more complicated
790   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
791     return (stupid_constraints ++ extra_constraints
792             ++ sc_constraints
793             ++ con_arg_constraints cls get_std_constrained_tys)
794
795   where
796        -- Constraints arising from the arguments of each constructor
797     con_arg_constraints cls' get_constrained_tys
798       = [ mkClassPred cls' [arg_ty]
799         | data_con <- tyConDataCons rep_tc,
800           arg_ty   <- ASSERT( isVanillaDataCon data_con )
801                         get_constrained_tys $
802                         dataConInstOrigArgTys data_con all_rep_tc_args,
803           not (isUnLiftedType arg_ty) ]
804                 -- No constraints for unlifted types
805                 -- See Note [Deriving and unboxed types]
806
807                 -- For functor-like classes, two things are different
808                 -- (a) We recurse over argument types to generate constraints
809                 --     See Functor examples in TcGenDeriv
810                 -- (b) The rep_tc_args will be one short
811     is_functor_like = getUnique cls `elem` functorLikeClassKeys
812
813     get_std_constrained_tys :: [Type] -> [Type]
814     get_std_constrained_tys tys
815         | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
816         | otherwise       = tys
817
818     rep_tc_tvs = tyConTyVars rep_tc
819     last_tv = last rep_tc_tvs
820     all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
821                       = rep_tc_args ++ [mkTyVarTy last_tv]
822                     | otherwise       = rep_tc_args
823
824         -- Constraints arising from superclasses
825         -- See Note [Superclasses of derived instance]
826     sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
827                                 (classSCTheta cls)
828
829         -- Stupid constraints
830     stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
831     subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
832
833         -- Extra Data constraints
834         -- The Data class (only) requires that for
835         --    instance (...) => Data (T t1 t2)
836         -- IF   t1:*, t2:*
837         -- THEN (Data t1, Data t2) are among the (...) constraints
838         -- Reason: when the IF holds, we generate a method
839         --             dataCast2 f = gcast2 f
840         --         and we need the Data constraints to typecheck the method
841     extra_constraints
842       | cls `hasKey` dataClassKey
843       , all (isLiftedTypeKind . typeKind) rep_tc_args
844       = [mkClassPred cls [ty] | ty <- rep_tc_args]
845       | otherwise
846       = []
847 \end{code}
848
849 Note [Getting base classes]
850 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
851 Functor and Typeable are defined in package 'base', and that is not available
852 when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
853 ghc-prim does not use Functor or Typeable implicitly via these lookups.
854
855 Note [Deriving and unboxed types]
856 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
857 We have some special hacks to support things like
858    data T = MkT Int# deriving( Ord, Show )
859
860 Specifically
861   * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
862     (which we know how to show)
863
864   * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
865     on some primitive types
866
867 It's all a bit ad hoc.
868
869
870 \begin{code}
871 ------------------------------------------------------------------
872 -- Check side conditions that dis-allow derivability for particular classes
873 -- This is *apart* from the newtype-deriving mechanism
874 --
875 -- Here we get the representation tycon in case of family instances as it has
876 -- the data constructors - but we need to be careful to fall back to the
877 -- family tycon (with indexes) in error messages.
878
879 data DerivStatus = CanDerive
880                  | DerivableClassError SDoc  -- Standard class, but can't do it
881                  | NonDerivableClass         -- Non-standard class
882
883 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
884                     -> TyCon -> [Type] -- tycon and its parameters
885                     -> DerivStatus
886 checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
887   | Just cond <- sideConditions mtheta cls
888   = case (cond (dflags, rep_tc, rep_tc_args)) of
889         Just err -> DerivableClassError err     -- Class-specific error
890         Nothing  | null cls_tys -> CanDerive    -- All derivable classes are unary, so
891                                                 -- cls_tys (the type args other than last)
892                                                 -- should be null
893                  | otherwise    -> DerivableClassError ty_args_why      -- e.g. deriving( Eq s )
894   | otherwise = NonDerivableClass       -- Not a standard class
895   where
896     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
897
898 checkTypeableConditions :: Condition
899 checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
900
901 nonStdErr :: Class -> SDoc
902 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
903
904 sideConditions :: DerivContext -> Class -> Maybe Condition
905 sideConditions mtheta cls
906   | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
907   | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
908   | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
909   | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
910   | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
911   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
912   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
913   | cls_key == dataClassKey        = Just (checkFlag Opt_DeriveDataTypeable `andCond`
914                                            cond_std `andCond` cond_args cls)
915   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
916                                            cond_functorOK True)  -- NB: no cond_std!
917   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
918                                            cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
919   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
920                                            cond_functorOK False)
921   | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
922                                            checkFlag Opt_DeriveGeneric)
923   | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
924                                            checkFlag Opt_DeriveGeneric)
925   | otherwise = Nothing
926   where
927     cls_key = getUnique cls
928     cond_std = cond_stdOK mtheta
929
930 type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc
931         -- first Bool is whether or not we are allowed to derive Data and Typeable
932         -- second Bool is whether or not we are allowed to derive Functor
933         -- TyCon is the *representation* tycon if the data type is an indexed one
934         -- [Type] are the type arguments to the (representation) TyCon
935         -- Nothing => OK
936
937 orCond :: Condition -> Condition -> Condition
938 orCond c1 c2 tc
939   = case c1 tc of
940         Nothing -> Nothing          -- c1 succeeds
941         Just x  -> case c2 tc of    -- c1 fails
942                      Nothing -> Nothing
943                      Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
944                                     -- Both fail
945
946 andCond :: Condition -> Condition -> Condition
947 andCond c1 c2 tc = case c1 tc of
948                      Nothing -> c2 tc   -- c1 succeeds
949                      Just x  -> Just x  -- c1 fails
950
951 cond_stdOK :: DerivContext -> Condition
952 cond_stdOK (Just _) _
953   = Nothing     -- Don't check these conservative conditions for
954                 -- standalone deriving; just generate the code
955                 -- and let the typechecker handle the result
956 cond_stdOK Nothing (_, rep_tc, _)
957   | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
958   | not (null con_whys) = Just (vcat con_whys $$ suggestion)
959   | otherwise           = Nothing
960   where
961     suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
962     data_cons   = tyConDataCons rep_tc
963     con_whys = mapCatMaybes check_con data_cons
964
965     check_con :: DataCon -> Maybe SDoc
966     check_con con
967       | isVanillaDataCon con
968       , all isTauTy (dataConOrigArgTys con) = Nothing
969       | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
970
971 no_cons_why :: TyCon -> SDoc
972 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
973                      ptext (sLit "must have at least one data constructor")
974
975 cond_RepresentableOk :: Condition
976 cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args
977
978 cond_Representable1Ok :: Condition
979 cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args
980
981 cond_enumOrProduct :: Class -> Condition
982 cond_enumOrProduct cls = cond_isEnumeration `orCond`
983                          (cond_isProduct `andCond` cond_args cls)
984
985 cond_args :: Class -> Condition
986 -- For some classes (eg Eq, Ord) we allow unlifted arg types
987 -- by generating specilaised code.  For others (eg Data) we don't.
988 cond_args cls (_, tc, _)
989   = case bad_args of
990       []      -> Nothing
991       (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
992                          2 (ptext (sLit "for type") <+> quotes (ppr ty)))
993   where
994     bad_args = [ arg_ty | con <- tyConDataCons tc
995                         , arg_ty <- dataConOrigArgTys con
996                         , isUnLiftedType arg_ty
997                         , not (ok_ty arg_ty) ]
998
999     cls_key = classKey cls
1000     ok_ty arg_ty
1001      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
1002      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
1003      | cls_key == showClassKey = check_in arg_ty boxConTbl
1004      | otherwise               = False    -- Read, Ix etc
1005
1006     check_in :: Type -> [(Type,a)] -> Bool
1007     check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
1008
1009
1010 cond_isEnumeration :: Condition
1011 cond_isEnumeration (_, rep_tc, _)
1012   | isEnumerationTyCon rep_tc = Nothing
1013   | otherwise                 = Just why
1014   where
1015     why = sep [ quotes (pprSourceTyCon rep_tc) <+>
1016                   ptext (sLit "must be an enumeration type")
1017               , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
1018                   -- See Note [Enumeration types] in TyCon
1019
1020 cond_isProduct :: Condition
1021 cond_isProduct (_, rep_tc, _)
1022   | isProductTyCon rep_tc = Nothing
1023   | otherwise             = Just why
1024   where
1025     why = quotes (pprSourceTyCon rep_tc) <+>
1026           ptext (sLit "must have precisely one constructor")
1027
1028 cond_typeableOK :: Condition
1029 -- OK for Typeable class
1030 -- Currently: (a) args all of kind *
1031 --            (b) 7 or fewer args
1032 cond_typeableOK (_, tc, _)
1033   | tyConArity tc > 7 = Just too_many
1034   | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
1035                       = Just bad_kind
1036   | otherwise         = Nothing
1037   where
1038     too_many = quotes (pprSourceTyCon tc) <+>
1039                ptext (sLit "must have 7 or fewer arguments")
1040     bad_kind = quotes (pprSourceTyCon tc) <+>
1041                ptext (sLit "must only have arguments of kind `*'")
1042
1043 functorLikeClassKeys :: [Unique]
1044 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
1045
1046 cond_functorOK :: Bool -> Condition
1047 -- OK for Functor/Foldable/Traversable class
1048 -- Currently: (a) at least one argument
1049 --            (b) don't use argument contravariantly
1050 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
1051 --            (d) optionally: don't use function types
1052 --            (e) no "stupid context" on data type
1053 cond_functorOK allowFunctions (_, rep_tc, _)
1054   | null tc_tvs
1055   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1056           <+> ptext (sLit "must have some type parameters"))
1057
1058   | not (null bad_stupid_theta)
1059   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1060           <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
1061
1062   | otherwise
1063   = msum (map check_con data_cons)      -- msum picks the first 'Just', if any
1064   where
1065     tc_tvs            = tyConTyVars rep_tc
1066     Just (_, last_tv) = snocView tc_tvs
1067     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
1068     is_bad pred       = last_tv `elemVarSet` tyVarsOfType pred
1069
1070     data_cons = tyConDataCons rep_tc
1071     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
1072
1073     check_vanilla :: DataCon -> Maybe SDoc
1074     check_vanilla con | isVanillaDataCon con = Nothing
1075                       | otherwise            = Just (badCon con existential)
1076
1077     ft_check :: DataCon -> FFoldType (Maybe SDoc)
1078     ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
1079                       , ft_co_var = Just (badCon con covariant)
1080                       , ft_fun = \x y -> if allowFunctions then x `mplus` y
1081                                                            else Just (badCon con functions)
1082                       , ft_tup = \_ xs  -> msum xs
1083                       , ft_ty_app = \_ x   -> x
1084                       , ft_bad_app = Just (badCon con wrong_arg)
1085                       , ft_forall = \_ x   -> x }
1086
1087     existential = ptext (sLit "must not have existential arguments")
1088     covariant   = ptext (sLit "must not use the type variable in a function argument")
1089     functions   = ptext (sLit "must not contain function types")
1090     wrong_arg   = ptext (sLit "must use the type variable only as the last argument of a data type")
1091
1092 checkFlag :: ExtensionFlag -> Condition
1093 checkFlag flag (dflags, _, _)
1094   | xopt flag dflags = Nothing
1095   | otherwise        = Just why
1096   where
1097     why = ptext (sLit "You need -X") <> text flag_str
1098           <+> ptext (sLit "to derive an instance for this class")
1099     flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
1100                  [s]   -> s
1101                  other -> pprPanic "checkFlag" (ppr other)
1102
1103 std_class_via_iso :: Class -> Bool
1104 -- These standard classes can be derived for a newtype
1105 -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
1106 -- because giving so gives the same results as generating the boilerplate
1107 std_class_via_iso clas
1108   = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
1109         -- Not Read/Show because they respect the type
1110         -- Not Enum, because newtypes are never in Enum
1111
1112
1113 non_iso_class :: Class -> Bool
1114 -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by isomorphism,
1115 -- even with -XGeneralizedNewtypeDeriving
1116 non_iso_class cls
1117   = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
1118                          , genClassKey, gen1ClassKey] ++ typeableClassKeys)
1119
1120 typeableClassKeys :: [Unique]
1121 typeableClassKeys = map getUnique typeableClassNames
1122
1123 new_dfun_name :: Class -> TyCon -> TcM Name
1124 new_dfun_name clas tycon        -- Just a simple wrapper
1125   = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
1126         ; newDFunName clas [mkTyConApp tycon []] loc }
1127         -- The type passed to newDFunName is only used to generate
1128         -- a suitable string; hence the empty type arg list
1129
1130 badCon :: DataCon -> SDoc -> SDoc
1131 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1132 \end{code}
1133
1134 Note [Superclasses of derived instance]
1135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1136 In general, a derived instance decl needs the superclasses of the derived
1137 class too.  So if we have
1138         data T a = ...deriving( Ord )
1139 then the initial context for Ord (T a) should include Eq (T a).  Often this is
1140 redundant; we'll also generate an Ord constraint for each constructor argument,
1141 and that will probably generate enough constraints to make the Eq (T a) constraint
1142 be satisfied too.  But not always; consider:
1143
1144  data S a = S
1145  instance Eq (S a)
1146  instance Ord (S a)
1147
1148  data T a = MkT (S a) deriving( Ord )
1149  instance Num a => Eq (T a)
1150
1151 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1152 Similarly consider:
1153         data T a = MkT deriving( Data, Typeable )
1154 Here there *is* no argument field, but we must nevertheless generate
1155 a context for the Data instances:
1156         instance Typable a => Data (T a) where ...
1157
1158
1159 %************************************************************************
1160 %*                                                                      *
1161                 Deriving newtypes
1162 %*                                                                      *
1163 %************************************************************************
1164
1165 \begin{code}
1166 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1167              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1168              -> DerivContext
1169              -> TcRn EarlyDerivSpec
1170 mkNewTypeEqn orig dflags tvs
1171              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1172 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1173   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1174   = do  { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1175         ; dfun_name <- new_dfun_name cls tycon
1176         ; loc <- getSrcSpanM
1177         ; let spec = DS { ds_loc = loc, ds_orig = orig
1178                         , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
1179                         , ds_cls = cls, ds_tys = inst_tys
1180                         , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1181                         , ds_theta =  mtheta `orElse` all_preds
1182                         , ds_newtype = True }
1183         ; return (if isJust mtheta then Right spec
1184                                    else Left spec) }
1185
1186   | otherwise
1187   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
1188       CanDerive -> go_for_it    -- Use the standard H98 method
1189       DerivableClassError msg   -- Error with standard class
1190         | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
1191         | otherwise                  -> bale_out msg
1192       NonDerivableClass         -- Must use newtype deriving
1193         | newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
1194         | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1195         | otherwise                  -> bale_out non_std
1196   where
1197         newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1198         go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1199         bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1200
1201         non_std    = nonStdErr cls
1202         suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1203
1204         -- Here is the plan for newtype derivings.  We see
1205         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1206         -- where t is a type,
1207         --       ak+1...an is a suffix of a1..an, and are all tyars
1208         --       ak+1...an do not occur free in t, nor in the s1..sm
1209         --       (C s1 ... sm) is a  *partial applications* of class C
1210         --                      with the last parameter missing
1211         --       (T a1 .. ak) matches the kind of C's last argument
1212         --              (and hence so does t)
1213         -- The latter kind-check has been done by deriveTyData already,
1214         -- and tc_args are already trimmed
1215         --
1216         -- We generate the instance
1217         --       instance forall ({a1..ak} u fvs(s1..sm)).
1218         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
1219         -- where T a1...ap is the partial application of
1220         --       the LHS of the correct kind and p >= k
1221         --
1222         --      NB: the variables below are:
1223         --              tc_tvs = [a1, ..., an]
1224         --              tyvars_to_keep = [a1, ..., ak]
1225         --              rep_ty = t ak .. an
1226         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
1227         --              tys = [s1, ..., sm]
1228         --              rep_fn' = t
1229         --
1230         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1231         -- We generate the instance
1232         --      instance Monad (ST s) => Monad (T s) where
1233
1234         nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1235                 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1236                 -- eta-reduces the representation type, so we know that
1237                 --      T a ~ S a a
1238                 -- That's convenient here, because we may have to apply
1239                 -- it to fewer than its original complement of arguments
1240
1241         -- Note [Newtype representation]
1242         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1243         -- Need newTyConRhs (*not* a recursive representation finder)
1244         -- to get the representation type. For example
1245         --      newtype B = MkB Int
1246         --      newtype A = MkA B deriving( Num )
1247         -- We want the Num instance of B, *not* the Num instance of Int,
1248         -- when making the Num instance of A!
1249         rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1250         rep_tys     = cls_tys ++ [rep_inst_ty]
1251         rep_pred    = mkClassPred cls rep_tys
1252                 -- rep_pred is the representation dictionary, from where
1253                 -- we are gong to get all the methods for the newtype
1254                 -- dictionary
1255
1256
1257     -- Next we figure out what superclass dictionaries to use
1258     -- See Note [Newtype deriving superclasses] above
1259
1260         cls_tyvars = classTyVars cls
1261         dfun_tvs = tyVarsOfTypes inst_tys
1262         inst_ty = mkTyConApp tycon tc_args
1263         inst_tys = cls_tys ++ [inst_ty]
1264         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1265                               (classSCTheta cls)
1266
1267                 -- If there are no tyvars, there's no need
1268                 -- to abstract over the dictionaries we need
1269                 -- Example:     newtype T = MkT Int deriving( C )
1270                 -- We get the derived instance
1271                 --              instance C T
1272                 -- rather than
1273                 --              instance C Int => C T
1274         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
1275
1276         -------------------------------------------------------------------
1277         --  Figuring out whether we can only do this newtype-deriving thing
1278
1279         can_derive_via_isomorphism
1280            =  not (non_iso_class cls)
1281            && arity_ok
1282            && eta_ok
1283            && ats_ok
1284 --         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
1285
1286         arity_ok = length cls_tys + 1 == classArity cls
1287                 -- Well kinded; eg not: newtype T ... deriving( ST )
1288                 --                      because ST needs *2* type params
1289
1290         -- Check that eta reduction is OK
1291         eta_ok = nt_eta_arity <= length rep_tc_args
1292                 -- The newtype can be eta-reduced to match the number
1293                 --     of type argument actually supplied
1294                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
1295                 --     Here the 'b' must be the same in the rep type (S [a] b)
1296                 --     And the [a] must not mention 'b'.  That's all handled
1297                 --     by nt_eta_rity.
1298
1299         ats_ok = null (classATs cls)
1300                -- No associated types for the class, because we don't
1301                -- currently generate type 'instance' decls; and cannot do
1302                -- so for 'data' instance decls
1303
1304         cant_derive_err
1305            = vcat [ ppUnless arity_ok arity_msg
1306                   , ppUnless eta_ok eta_msg
1307                   , ppUnless ats_ok ats_msg ]
1308         arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1309         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
1310         ats_msg   = ptext (sLit "the class has associated types")
1311 \end{code}
1312
1313 Note [Recursive newtypes]
1314 ~~~~~~~~~~~~~~~~~~~~~~~~~
1315 Newtype deriving works fine, even if the newtype is recursive.
1316 e.g.    newtype S1 = S1 [T1 ()]
1317         newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1318 Remember, too, that type families are curretly (conservatively) given
1319 a recursive flag, so this also allows newtype deriving to work
1320 for type famillies.
1321
1322 We used to exclude recursive types, because we had a rather simple
1323 minded way of generating the instance decl:
1324    newtype A = MkA [A]
1325    instance Eq [A] => Eq A      -- Makes typechecker loop!
1326 But now we require a simple context, so it's ok.
1327
1328
1329 %************************************************************************
1330 %*                                                                      *
1331 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1332 %*                                                                      *
1333 %************************************************************************
1334
1335 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1336 terms, which is the final correct RHS for the corresponding original
1337 equation.
1338 \begin{itemize}
1339 \item
1340 Each (k,TyVarTy tv) in a solution constrains only a type
1341 variable, tv.
1342
1343 \item
1344 The (k,TyVarTy tv) pairs in a solution are canonically
1345 ordered by sorting on type varible, tv, (major key) and then class, k,
1346 (minor key)
1347 \end{itemize}
1348
1349 \begin{code}
1350 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1351
1352 inferInstanceContexts _ [] = return []
1353
1354 inferInstanceContexts oflag infer_specs
1355   = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1356         ; iterate_deriv 1 initial_solutions }
1357   where
1358     ------------------------------------------------------------------
1359         -- The initial solutions for the equations claim that each
1360         -- instance has an empty context; this solution is certainly
1361         -- in canonical form.
1362     initial_solutions :: [ThetaType]
1363     initial_solutions = [ [] | _ <- infer_specs ]
1364
1365     ------------------------------------------------------------------
1366         -- iterate_deriv calculates the next batch of solutions,
1367         -- compares it with the current one; finishes if they are the
1368         -- same, otherwise recurses with the new solutions.
1369         -- It fails if any iteration fails
1370     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1371     iterate_deriv n current_solns
1372       | n > 20  -- Looks as if we are in an infinite loop
1373                 -- This can happen if we have -XUndecidableInstances
1374                 -- (See TcSimplify.tcSimplifyDeriv.)
1375       = pprPanic "solveDerivEqns: probable loop"
1376                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1377       | otherwise
1378       = do {      -- Extend the inst info from the explicit instance decls
1379                   -- with the current set of solutions, and simplify each RHS
1380              let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1381                                            current_solns infer_specs
1382            ; new_solns <- checkNoErrs $
1383                           extendLocalInstEnv inst_specs $
1384                           mapM gen_soln infer_specs
1385
1386            ; let eqList :: (a -> b -> Bool) -> [a] -> [b] -> Bool
1387                  eqList f xs ys = length xs == length ys && and (zipWith f xs ys)
1388
1389            ; if (eqList (eqList eqType) current_solns new_solns) then
1390                 return [ spec { ds_theta = soln }
1391                        | (spec, soln) <- zip infer_specs current_solns ]
1392              else
1393                 iterate_deriv (n+1) new_solns }
1394
1395     ------------------------------------------------------------------
1396     gen_soln :: DerivSpec  -> TcM [PredType]
1397     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1398                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1399       = setSrcSpan loc  $
1400         addErrCtxt (derivInstCtxt the_pred) $
1401         do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
1402                 -- checkValidInstance tyvars theta clas inst_tys
1403                 -- Not necessary; see Note [Exotic derived instance contexts]
1404                 --                in TcSimplify
1405
1406            ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1407                 -- Claim: the result instance declaration is guaranteed valid
1408                 -- Hence no need to call:
1409                 --   checkValidInstance tyvars theta clas inst_tys
1410            ; return (sortBy cmpType theta) }    -- Canonicalise before returning the solution
1411       where
1412         the_pred = mkClassPred clas inst_tys
1413
1414 ------------------------------------------------------------------
1415 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> ClsInst
1416 mkInstance overlap_flag theta
1417             (DS { ds_name = dfun_name
1418                 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1419   = mkLocalInstance dfun overlap_flag
1420   where
1421     dfun = mkDictFunId dfun_name tyvars theta clas tys
1422
1423
1424 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
1425 -- Add new locally-defined instances; don't bother to check
1426 -- for functional dependency errors -- that'll happen in TcInstDcls
1427 extendLocalInstEnv dfuns thing_inside
1428  = do { env <- getGblEnv
1429       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1430              env'      = env { tcg_inst_env = inst_env' }
1431       ; setGblEnv env' thing_inside }
1432 \end{code}
1433
1434
1435 %************************************************************************
1436 %*                                                                      *
1437 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1438 %*                                                                      *
1439 %************************************************************************
1440
1441 After all the trouble to figure out the required context for the
1442 derived instance declarations, all that's left is to chug along to
1443 produce them.  They will then be shoved into @tcInstDecls2@, which
1444 will do all its usual business.
1445
1446 There are lots of possibilities for code to generate.  Here are
1447 various general remarks.
1448
1449 PRINCIPLES:
1450 \begin{itemize}
1451 \item
1452 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1453 ``you-couldn't-do-better-by-hand'' efficient.
1454
1455 \item
1456 Deriving @Show@---also pretty common--- should also be reasonable good code.
1457
1458 \item
1459 Deriving for the other classes isn't that common or that big a deal.
1460 \end{itemize}
1461
1462 PRAGMATICS:
1463
1464 \begin{itemize}
1465 \item
1466 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1467
1468 \item
1469 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1470
1471 \item
1472 We {\em normally} generate code only for the non-defaulted methods;
1473 there are some exceptions for @Eq@ and (especially) @Ord@...
1474
1475 \item
1476 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1477 constructor's numeric (@Int#@) tag.  These are generated by
1478 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1479 these is around is given by @hasCon2TagFun@.
1480
1481 The examples under the different sections below will make this
1482 clearer.
1483
1484 \item
1485 Much less often (really just for deriving @Ix@), we use a
1486 @_tag2con_<tycon>@ function.  See the examples.
1487
1488 \item
1489 We use the renamer!!!  Reason: we're supposed to be
1490 producing @LHsBinds Name@ for the methods, but that means
1491 producing correctly-uniquified code on the fly.  This is entirely
1492 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1493 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1494 the renamer.  What a great hack!
1495 \end{itemize}
1496
1497 \begin{code}
1498 -- Generate the InstInfo for the required instance paired with the
1499 --   *representation* tycon for that instance,
1500 -- plus any auxiliary bindings required
1501 --
1502 -- Representation tycons differ from the tycon in the instance signature in
1503 -- case of instances for indexed families.
1504 --
1505 genInst :: Bool             -- True <=> standalone deriving
1506         -> OverlapFlag
1507         -> CommonAuxiliaries
1508         -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
1509 genInst standalone_deriv oflag comauxs
1510         spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1511                  , ds_theta = theta, ds_newtype = is_newtype
1512                  , ds_name = name, ds_cls = clas })
1513   | is_newtype
1514   = return (InstInfo { iSpec   = inst_spec
1515                      , iBinds  = NewTypeDerived co rep_tycon }, emptyBag)
1516
1517   | otherwise
1518   = do { fix_env <- getFixityEnv
1519        ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
1520                                         fix_env clas name rep_tycon
1521                                         (lookup rep_tycon comauxs)
1522        ; let inst_info = InstInfo { iSpec   = inst_spec
1523                                   , iBinds  = VanillaInst meth_binds []
1524                                                 standalone_deriv }
1525        ; return ( inst_info, deriv_stuff) }
1526   where
1527
1528     inst_spec = mkInstance oflag theta spec
1529     co1 = case tyConFamilyCoercion_maybe rep_tycon of
1530               Just co_con -> mkTcAxInstCo co_con rep_tc_args
1531               Nothing     -> id_co
1532               -- Not a family => rep_tycon = main tycon
1533     co2 = mkTcAxInstCo (newTyConCo rep_tycon) rep_tc_args
1534     co  = mkTcForAllCos tvs (co1 `mkTcTransCo` co2)
1535     id_co = mkTcReflCo (mkTyConApp rep_tycon rep_tc_args)
1536
1537 -- Example: newtype instance N [a] = N1 (Tree a)
1538 --          deriving instance Eq b => Eq (N [(b,b)])
1539 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1540 -- When dealing with the deriving clause
1541 --    co1 : N [(b,b)] ~ R1:N (b,b)
1542 --    co2 : R1:N (b,b) ~ Tree (b,b)
1543 --    co  : N [(b,b)] ~ Tree (b,b)
1544
1545 genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
1546               -> Maybe CommonAuxiliary
1547               -> TcM (LHsBinds RdrName, BagDerivStuff)
1548 genDerivStuff loc fix_env clas name tycon comaux_maybe
1549   | className clas `elem` typeableClassNames
1550   = do dflags <- getDynFlags
1551        return (gen_Typeable_binds dflags loc tycon, emptyBag)
1552
1553   | ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
1554   = let gk =  if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One
1555         Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
1556     in do
1557       (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name)
1558       return (binds, DerivFamInst faminst `consBag` emptyBag)
1559
1560   | otherwise                      -- Non-monadic generators
1561   = do dflags <- getDynFlags
1562        case assocMaybe (gen_list dflags) (getUnique clas) of
1563         Just gen_fn -> return (gen_fn loc tycon)
1564         Nothing     -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
1565   where
1566     ck = classKey clas
1567
1568     gen_list :: DynFlags
1569              -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
1570     gen_list dflags
1571              = [(eqClassKey, gen_Eq_binds)
1572                ,(ordClassKey, gen_Ord_binds)
1573                ,(enumClassKey, gen_Enum_binds)
1574                ,(boundedClassKey, gen_Bounded_binds)
1575                ,(ixClassKey, gen_Ix_binds)
1576                ,(showClassKey, gen_Show_binds fix_env)
1577                ,(readClassKey, gen_Read_binds fix_env)
1578                ,(dataClassKey, gen_Data_binds dflags)
1579                ,(functorClassKey, gen_Functor_binds)
1580                ,(foldableClassKey, gen_Foldable_binds)
1581                ,(traversableClassKey, gen_Traversable_binds)
1582                ]
1583 \end{code}
1584
1585 %************************************************************************
1586 %*                                                                      *
1587 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1588 %*                                                                      *
1589 %************************************************************************
1590
1591 \begin{code}
1592 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc
1593 derivingKindErr tc cls cls_tys cls_kind
1594   = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1595                 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1596        2 (ptext (sLit "Class") <+> quotes (ppr cls)
1597             <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1598
1599 derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
1600 derivingEtaErr cls cls_tys inst_ty
1601   = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1602          nest 2 (ptext (sLit "instance (...) =>")
1603                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1604
1605 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> MsgDoc
1606 typeFamilyPapErr tc cls cls_tys inst_ty
1607   = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1608        2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1609
1610 derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc
1611 derivingThingErr newtype_deriving clas tys ty why
1612   = sep [(hang (ptext (sLit "Can't make a derived instance of"))
1613              2 (quotes (ppr pred))
1614           $$ nest 2 extra) <> colon,
1615          nest 2 why]
1616   where
1617     extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
1618           | otherwise        = empty
1619     pred = mkClassPred clas (tys ++ [ty])
1620
1621 derivingHiddenErr :: TyCon -> SDoc
1622 derivingHiddenErr tc
1623   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1624        2 (ptext (sLit "so you cannot derive an instance for it"))
1625
1626 standaloneCtxt :: LHsType Name -> SDoc
1627 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1628                        2 (quotes (ppr ty))
1629
1630 derivInstCtxt :: PredType -> MsgDoc
1631 derivInstCtxt pred
1632   = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
1633 \end{code}