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