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