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