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