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