97a548d24e74af46f99fe22e5e322e0847dd4f03
[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
584        ; let cls_tys = take (length inst_tys - 1) inst_tys
585              inst_ty = last inst_tys
586        ; traceTc "Standalone deriving:" $ vcat
587               [ text "class:" <+> ppr cls
588               , text "class types:" <+> ppr cls_tys
589               , text "type:" <+> ppr inst_ty ]
590        ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
591                    (Just theta) }
592
593 ------------------------------------------------------------------
594 deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
595              -> LHsType Name                 -- The deriving predicate
596              -> TcM EarlyDerivSpec
597 -- The deriving clause of a data or newtype declaration
598 deriveTyData tvs tc tc_args (L loc deriv_pred)
599   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
600     tcExtendTyVarEnv tvs $      -- Deriving preds may (now) mention
601                                 -- the type variables for the type constructor
602
603     do  { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
604                 -- The "deriv_pred" is a LHsType to take account of the fact that for
605                 -- newtype deriving we allow deriving (forall a. C [a]).
606
607                 -- Typeable is special
608         ; if className cls == typeableClassName
609           then do {
610         ; dflags <- getDynFlags
611         ; case checkTypeableConditions (dflags, tc, tc_args) of
612                Just err -> failWithTc (derivingThingErr False cls cls_tys
613                                          (mkTyConApp tc tc_args) err)
614                Nothing  -> mkEqnHelp DerivOrigin tvs cls cls_tys
615                              (mkTyConApp tc (kindVarsOnly tc_args)) Nothing }
616           else do {
617
618         -- Given data T a b c = ... deriving( C d ),
619         -- we want to drop type variables from T so that (C d (T a)) is well-kinded
620         ; let cls_tyvars     = classTyVars cls
621               kind           = tyVarKind (last cls_tyvars)
622               (arg_kinds, _) = splitKindFunTys kind
623               n_args_to_drop = length arg_kinds
624               n_args_to_keep = tyConArity tc - n_args_to_drop
625               args_to_drop   = drop n_args_to_keep tc_args
626               inst_ty        = mkTyConApp tc (take n_args_to_keep tc_args)
627               inst_ty_kind   = typeKind inst_ty
628               dropped_tvs    = tyVarsOfTypes args_to_drop
629               univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
630                                              `minusVarSet` dropped_tvs
631
632         ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$
633                      pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
634
635         -- Check that the result really is well-kinded
636         ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
637                   (derivingKindErr tc cls cls_tys kind)
638
639         ; checkTc (all isTyVarTy args_to_drop &&                         -- (a)
640                    sizeVarSet dropped_tvs == n_args_to_drop &&           -- (b)
641                    tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (c)
642                   (derivingEtaErr cls cls_tys inst_ty)
643                 -- Check that
644                 --  (a) The args to drop are all type variables; eg reject:
645                 --              data instance T a Int = .... deriving( Monad )
646                 --  (a) The data type can be eta-reduced; eg reject:
647                 --              data instance T a a = ... deriving( Monad )
648                 --  (b) The type class args do not mention any of the dropped type
649                 --      variables
650                 --              newtype T a s = ... deriving( ST s )
651
652         ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
653   where
654     kindVarsOnly :: [Type] -> [Type]
655     kindVarsOnly [] = []
656     kindVarsOnly (t:ts) | Just v <- getTyVar_maybe t
657                         , isKindVar v = t : kindVarsOnly ts
658                         | otherwise   =     kindVarsOnly ts
659 \end{code}
660
661
662 \begin{code}
663 mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
664           -> DerivContext       -- Just    => context supplied (standalone deriving)
665                                 -- Nothing => context inferred (deriving on data decl)
666           -> TcRn EarlyDerivSpec
667 -- Make the EarlyDerivSpec for an instance
668 --      forall tvs. theta => cls (tys ++ [ty])
669 -- where the 'theta' is optional (that's the Maybe part)
670 -- Assumes that this declaration is well-kinded
671
672 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
673   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
674   , className cls == typeableClassName || isAlgTyCon tycon
675   -- Avoid functions, primitive types, etc, unless it's Typeable
676   = mk_alg_eqn tycon tc_args
677
678   | otherwise
679   = failWithTc (derivingThingErr False cls cls_tys tc_app
680                (ptext (sLit "The last argument of the instance must be a data or newtype application")))
681
682   where
683      bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
684
685      mk_alg_eqn tycon tc_args
686       | className cls `elem` oldTypeableClassNames
687       = do { dflags <- getDynFlags
688            ; case checkOldTypeableConditions (dflags, tycon, tc_args) of
689                Just err -> bale_out err
690                Nothing  -> mkOldTypeableEqn orig tvs cls tycon tc_args mtheta }
691
692       | className cls == typeableClassName
693       -- We checked for errors before, so we don't need to do that again
694       = mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta
695
696       | otherwise
697       = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args
698                   -- Be careful to test rep_tc here: in the case of families,
699                   -- we want to check the instance tycon, not the family tycon
700
701            -- For standalone deriving (mtheta /= Nothing),
702            -- check that all the data constructors are in scope.
703            ; rdr_env <- getGlobalRdrEnv
704            ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
705                                     (isAbstractTyCon rep_tc ||
706                                      any not_in_scope (tyConDataCons rep_tc))
707                  not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
708            ; unless (isNothing mtheta || not hidden_data_cons)
709                     (bale_out (derivingHiddenErr tycon))
710
711            ; dflags <- getDynFlags
712            ; if isDataTyCon rep_tc then
713                 mkDataTypeEqn orig dflags tvs cls cls_tys
714                               tycon tc_args rep_tc rep_tc_args mtheta
715              else
716                 mkNewTypeEqn orig dflags tvs cls cls_tys
717                              tycon tc_args rep_tc rep_tc_args mtheta }
718
719      lookup_data_fam :: TyCon -> [Type] -> TcM (TyCon, [Type])
720      -- Find the instance of a data family
721      -- Note [Looking up family instances for deriving]
722      lookup_data_fam tycon tys
723        | not (isFamilyTyCon tycon)
724        = return (tycon, tys)
725        | otherwise
726        = ASSERT( isAlgTyCon tycon )
727          do { maybeFamInst <- tcLookupFamInst tycon tys
728             ; case maybeFamInst of
729                 Nothing -> bale_out (ptext (sLit "No family instance for")
730                                      <+> quotes (pprTypeApp tycon tys))
731                 Just (FamInstMatch { fim_instance = famInst
732                                    , fim_index    = index
733                                    , fim_tys      = tys })
734                   -> ASSERT( index == 0 )
735                      let tycon' = dataFamInstRepTyCon famInst
736                      in return (tycon', tys) }
737 \end{code}
738
739 Note [Looking up family instances for deriving]
740 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
741 tcLookupFamInstExact is an auxiliary lookup wrapper which requires
742 that looked-up family instances exist.  If called with a vanilla
743 tycon, the old type application is simply returned.
744
745 If we have
746   data instance F () = ... deriving Eq
747   data instance F () = ... deriving Eq
748 then tcLookupFamInstExact will be confused by the two matches;
749 but that can't happen because tcInstDecls1 doesn't call tcDeriving
750 if there are any overlaps.
751
752 There are two other things that might go wrong with the lookup.
753 First, we might see a standalone deriving clause
754    deriving Eq (F ())
755 when there is no data instance F () in scope. 
756
757 Note that it's OK to have
758   data instance F [a] = ...
759   deriving Eq (F [(a,b)])
760 where the match is not exact; the same holds for ordinary data types
761 with standalone deriving declarations.
762
763 Note [Deriving, type families, and partial applications]
764 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
765 When there are no type families, it's quite easy:
766
767     newtype S a = MkS [a]
768     -- :CoS :: S  ~ []  -- Eta-reduced
769
770     instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
771     instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
772
773 When type familes are involved it's trickier:
774
775     data family T a b
776     newtype instance T Int a = MkT [a] deriving( Eq, Monad )
777     -- :RT is the representation type for (T Int a)
778     --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
779     --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!
780
781     instance Eq [a] => Eq (T Int a)     -- easy by coercion
782        -- d1 :: Eq [a]
783        -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
784
785     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
786        -- d1 :: Monad []
787        -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) 
788
789 Note the need for the eta-reduced rule axioms.  After all, we can
790 write it out
791     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
792       return x = MkT [x]
793       ... etc ...
794
795 See Note [Eta reduction for data family axioms] in TcInstDcls.
796
797
798 %************************************************************************
799 %*                                                                      *
800                 Deriving data types
801 %*                                                                      *
802 %************************************************************************
803
804 \begin{code}
805 mkDataTypeEqn :: CtOrigin
806               -> DynFlags
807               -> [Var]                  -- Universally quantified type variables in the instance
808               -> Class                  -- Class for which we need to derive an instance
809               -> [Type]                 -- Other parameters to the class except the last
810               -> TyCon                  -- Type constructor for which the instance is requested
811                                         --    (last parameter to the type class)
812               -> [Type]                 -- Parameters to the type constructor
813               -> TyCon                  -- rep of the above (for type families)
814               -> [Type]                 -- rep of the above
815               -> DerivContext        -- Context of the instance, for standalone deriving
816               -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error
817
818 mkDataTypeEqn orig dflags tvs cls cls_tys
819               tycon tc_args rep_tc rep_tc_args mtheta
820   = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
821         -- NB: pass the *representation* tycon to checkSideConditions
822         CanDerive               -> go_for_it
823         NonDerivableClass       -> bale_out (nonStdErr cls)
824         DerivableClassError msg -> bale_out msg
825   where
826     go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
827     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
828
829 mk_data_eqn :: CtOrigin -> [TyVar] -> Class
830             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
831             -> TcM EarlyDerivSpec
832 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
833   = do  { loc                  <- getSrcSpanM
834         ; dfun_name            <- new_dfun_name cls tycon
835         ; inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
836         ; let spec = DS { ds_loc = loc, ds_orig = orig
837                         , ds_name = dfun_name, ds_tvs = tvs
838                         , ds_cls = cls, ds_tys = inst_tys
839                         , ds_tc = rep_tc, ds_tc_args = rep_tc_args
840                         , ds_theta =  mtheta `orElse` inferred_constraints
841                         , ds_newtype = False }
842
843         ; return (if isJust mtheta then Right spec      -- Specified context
844                                    else Left spec) }    -- Infer context
845   where
846     inst_tys = [mkTyConApp tycon tc_args]
847
848 ----------------------
849 mkOldTypeableEqn :: CtOrigin -> [TyVar] -> Class
850                     -> TyCon -> [TcType] -> DerivContext
851                     -> TcM EarlyDerivSpec
852 -- The "old" (pre GHC 7.8 polykinded Typeable) deriving Typeable
853 -- used a horrid family of classes: Typeable, Typeable1, Typeable2, ... Typeable7
854 mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
855         -- The Typeable class is special in several ways
856         --        data T a b = ... deriving( Typeable )
857         -- gives
858         --        instance Typeable2 T where ...
859         -- Notice that:
860         -- 1. There are no constraints in the instance
861         -- 2. There are no type variables either
862         -- 3. The actual class we want to generate isn't necessarily
863         --      Typeable; it depends on the arity of the type
864   | isNothing mtheta    -- deriving on a data type decl
865   = do  { checkTc (cls `hasKey` oldTypeableClassKey)
866                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
867         ; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
868                       -- See Note [Getting base classes]
869         ; mkOldTypeableEqn orig tvs real_cls tycon [] (Just []) }
870
871   | otherwise           -- standalone deriving
872   = do  { checkTc (null tc_args)
873                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
874                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
875         ; dfun_name <- new_dfun_name cls tycon
876         ; loc <- getSrcSpanM
877         ; return (Right $
878                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
879                      , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
880                      , ds_tc = tycon, ds_tc_args = []
881                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
882
883 mkPolyKindedTypeableEqn :: CtOrigin -> [TyVar] -> Class -> [TcType]
884                         -> TyCon -> [TcType] -> DerivContext
885                         -> TcM EarlyDerivSpec
886 mkPolyKindedTypeableEqn orig tvs cls _cls_tys tycon tc_args mtheta
887   -- The kind-polymorphic Typeable class is less special; namely, there is no
888   -- need to select the class with the right kind anymore, as we only have one.
889   = do  { checkTc (all is_kind_var tc_args)
890                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
891                         <+> ppr tycon <> rparen)
892         ; dfun_name <- new_dfun_name cls tycon
893         ; loc <- getSrcSpanM
894         ; let tc_app = mkTyConApp tycon tc_args
895         ; return (Right $
896                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name
897                      , ds_tvs = filter isKindVar tvs, ds_cls = cls
898                      , ds_tys = typeKind tc_app : [tc_app]
899                          -- Remember, Typeable :: forall k. k -> *
900                      , ds_tc = tycon, ds_tc_args = tc_args
901                      , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
902                      , ds_newtype = False })  }
903   where 
904     is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
905                            Just v  -> isKindVar v
906                            Nothing -> False
907
908 ----------------------
909 inferConstraints :: Class -> [TcType]
910                  -> TyCon -> [TcType]
911                  -> TcM ThetaType
912 -- Generate a sufficiently large set of constraints that typechecking the
913 -- generated method definitions should succeed.   This set will be simplified
914 -- before being used in the instance declaration
915 inferConstraints cls inst_tys rep_tc rep_tc_args
916   | cls `hasKey` genClassKey    -- Generic constraints are easy
917   = return []
918
919   | cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
920   = ASSERT (length rep_tc_tvs > 0)   -- See Note [Getting base classes]
921     do { functorClass <- tcLookupClass functorClassName
922        ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }
923
924   | otherwise  -- The others are a bit more complicated
925   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
926     return (stupid_constraints ++ extra_constraints
927             ++ sc_constraints
928             ++ con_arg_constraints cls get_std_constrained_tys)
929
930   where
931        -- Constraints arising from the arguments of each constructor
932     con_arg_constraints cls' get_constrained_tys
933       = [ mkClassPred cls' [arg_ty]
934         | data_con <- tyConDataCons rep_tc,
935           arg_ty   <- ASSERT( isVanillaDataCon data_con )
936                         get_constrained_tys $
937                         dataConInstOrigArgTys data_con all_rep_tc_args,
938           not (isUnLiftedType arg_ty) ]
939                 -- No constraints for unlifted types
940                 -- See Note [Deriving and unboxed types]
941
942                 -- For functor-like classes, two things are different
943                 -- (a) We recurse over argument types to generate constraints
944                 --     See Functor examples in TcGenDeriv
945                 -- (b) The rep_tc_args will be one short
946     is_functor_like = getUnique cls `elem` functorLikeClassKeys
947
948     get_std_constrained_tys :: [Type] -> [Type]
949     get_std_constrained_tys tys
950         | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
951         | otherwise       = tys
952
953     rep_tc_tvs = tyConTyVars rep_tc
954     last_tv = last rep_tc_tvs
955     all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
956                       = rep_tc_args ++ [mkTyVarTy last_tv]
957                     | otherwise       = rep_tc_args
958
959         -- Constraints arising from superclasses
960         -- See Note [Superclasses of derived instance]
961     sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
962                                 (classSCTheta cls)
963
964         -- Stupid constraints
965     stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
966     subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
967
968         -- Extra Data constraints
969         -- The Data class (only) requires that for
970         --    instance (...) => Data (T t1 t2)
971         -- IF   t1:*, t2:*
972         -- THEN (Data t1, Data t2) are among the (...) constraints
973         -- Reason: when the IF holds, we generate a method
974         --             dataCast2 f = gcast2 f
975         --         and we need the Data constraints to typecheck the method
976     extra_constraints
977       | cls `hasKey` dataClassKey
978       , all (isLiftedTypeKind . typeKind) rep_tc_args
979       = [mkClassPred cls [ty] | ty <- rep_tc_args]
980       | otherwise
981       = []
982 \end{code}
983
984 Note [Getting base classes]
985 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
986 Functor and Typeable are defined in package 'base', and that is not available
987 when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
988 ghc-prim does not use Functor or Typeable implicitly via these lookups.
989
990 Note [Deriving and unboxed types]
991 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
992 We have some special hacks to support things like
993    data T = MkT Int# deriving( Ord, Show )
994
995 Specifically
996   * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
997     (which we know how to show)
998
999   * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
1000     on some primitive types
1001
1002 It's all a bit ad hoc.
1003
1004
1005 \begin{code}
1006 ------------------------------------------------------------------
1007 -- Check side conditions that dis-allow derivability for particular classes
1008 -- This is *apart* from the newtype-deriving mechanism
1009 --
1010 -- Here we get the representation tycon in case of family instances as it has
1011 -- the data constructors - but we need to be careful to fall back to the
1012 -- family tycon (with indexes) in error messages.
1013
1014 data DerivStatus = CanDerive
1015                  | DerivableClassError SDoc  -- Standard class, but can't do it
1016                  | NonDerivableClass         -- Non-standard class
1017
1018 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
1019                     -> TyCon -> [Type] -- tycon and its parameters
1020                     -> DerivStatus
1021 checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
1022   | Just cond <- sideConditions mtheta cls
1023   = case (cond (dflags, rep_tc, rep_tc_args)) of
1024         Just err -> DerivableClassError err     -- Class-specific error
1025         Nothing  | null cls_tys -> CanDerive    -- All derivable classes are unary, so
1026                                                 -- cls_tys (the type args other than last)
1027                                                 -- should be null
1028                  | otherwise    -> DerivableClassError ty_args_why      -- e.g. deriving( Eq s )
1029   | otherwise = NonDerivableClass       -- Not a standard class
1030   where
1031     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
1032
1033 checkTypeableConditions, checkOldTypeableConditions :: Condition
1034 checkTypeableConditions    = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK
1035 checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
1036
1037 nonStdErr :: Class -> SDoc
1038 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
1039
1040 sideConditions :: DerivContext -> Class -> Maybe Condition
1041 sideConditions mtheta cls
1042   | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
1043   | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
1044   | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
1045   | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
1046   | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
1047   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
1048   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
1049   | cls_key == dataClassKey        = Just (checkFlag Opt_DeriveDataTypeable `andCond`
1050                                            cond_std `andCond` cond_args cls)
1051   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
1052                                            cond_functorOK True)  -- NB: no cond_std!
1053   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
1054                                            cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
1055   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
1056                                            cond_functorOK False)
1057   | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
1058                                            checkFlag Opt_DeriveGeneric)
1059   | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
1060                                            checkFlag Opt_DeriveGeneric)
1061   | otherwise = Nothing
1062   where
1063     cls_key = getUnique cls
1064     cond_std = cond_stdOK mtheta
1065
1066 type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc
1067         -- first Bool is whether or not we are allowed to derive Data and Typeable
1068         -- second Bool is whether or not we are allowed to derive Functor
1069         -- TyCon is the *representation* tycon if the data type is an indexed one
1070         -- [Type] are the type arguments to the (representation) TyCon
1071         -- Nothing => OK
1072
1073 orCond :: Condition -> Condition -> Condition
1074 orCond c1 c2 tc
1075   = case c1 tc of
1076         Nothing -> Nothing          -- c1 succeeds
1077         Just x  -> case c2 tc of    -- c1 fails
1078                      Nothing -> Nothing
1079                      Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
1080                                     -- Both fail
1081
1082 andCond :: Condition -> Condition -> Condition
1083 andCond c1 c2 tc = case c1 tc of
1084                      Nothing -> c2 tc   -- c1 succeeds
1085                      Just x  -> Just x  -- c1 fails
1086
1087 cond_stdOK :: DerivContext -> Condition
1088 cond_stdOK (Just _) _
1089   = Nothing     -- Don't check these conservative conditions for
1090                 -- standalone deriving; just generate the code
1091                 -- and let the typechecker handle the result
1092 cond_stdOK Nothing (_, rep_tc, _)
1093   | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
1094   | not (null con_whys) = Just (vcat con_whys $$ suggestion)
1095   | otherwise           = Nothing
1096   where
1097     suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
1098     data_cons   = tyConDataCons rep_tc
1099     con_whys = mapCatMaybes check_con data_cons
1100
1101     check_con :: DataCon -> Maybe SDoc
1102     check_con con
1103       | isVanillaDataCon con
1104       , all isTauTy (dataConOrigArgTys con) = Nothing
1105       | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
1106
1107 no_cons_why :: TyCon -> SDoc
1108 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
1109                      ptext (sLit "must have at least one data constructor")
1110
1111 cond_RepresentableOk :: Condition
1112 cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args
1113
1114 cond_Representable1Ok :: Condition
1115 cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args
1116
1117 cond_enumOrProduct :: Class -> Condition
1118 cond_enumOrProduct cls = cond_isEnumeration `orCond`
1119                          (cond_isProduct `andCond` cond_args cls)
1120
1121 cond_args :: Class -> Condition
1122 -- For some classes (eg Eq, Ord) we allow unlifted arg types
1123 -- by generating specilaised code.  For others (eg Data) we don't.
1124 cond_args cls (_, tc, _)
1125   = case bad_args of
1126       []      -> Nothing
1127       (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
1128                          2 (ptext (sLit "for type") <+> quotes (ppr ty)))
1129   where
1130     bad_args = [ arg_ty | con <- tyConDataCons tc
1131                         , arg_ty <- dataConOrigArgTys con
1132                         , isUnLiftedType arg_ty
1133                         , not (ok_ty arg_ty) ]
1134
1135     cls_key = classKey cls
1136     ok_ty arg_ty
1137      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
1138      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
1139      | cls_key == showClassKey = check_in arg_ty boxConTbl
1140      | otherwise               = False    -- Read, Ix etc
1141
1142     check_in :: Type -> [(Type,a)] -> Bool
1143     check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
1144
1145
1146 cond_isEnumeration :: Condition
1147 cond_isEnumeration (_, rep_tc, _)
1148   | isEnumerationTyCon rep_tc = Nothing
1149   | otherwise                 = Just why
1150   where
1151     why = sep [ quotes (pprSourceTyCon rep_tc) <+>
1152                   ptext (sLit "must be an enumeration type")
1153               , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
1154                   -- See Note [Enumeration types] in TyCon
1155
1156 cond_isProduct :: Condition
1157 cond_isProduct (_, rep_tc, _)
1158   | isProductTyCon rep_tc = Nothing
1159   | otherwise             = Just why
1160   where
1161     why = quotes (pprSourceTyCon rep_tc) <+>
1162           ptext (sLit "must have precisely one constructor")
1163
1164 cond_oldTypeableOK :: Condition
1165 -- OK for kind-monomorphic Typeable class
1166 -- Currently: (a) args all of kind *
1167 --            (b) 7 or fewer args
1168 cond_oldTypeableOK (_, tc, _)
1169   | tyConArity tc > 7 = Just too_many
1170   | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
1171                       = Just bad_kind
1172   | otherwise         = Nothing
1173   where
1174     too_many = quotes (pprSourceTyCon tc) <+>
1175                ptext (sLit "must have 7 or fewer arguments")
1176     bad_kind = quotes (pprSourceTyCon tc) <+>
1177                ptext (sLit "must only have arguments of kind `*'")
1178
1179 cond_TypeableOK :: Condition
1180 -- Only not ok if it's a data instance
1181 cond_TypeableOK (_, tc, tc_args)
1182   | isDataFamilyTyCon tc && not (null tc_args)
1183   = Just no_families
1184
1185   | otherwise
1186   = Nothing
1187   where
1188     no_families = sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;")
1189                       , ptext (sLit "derive Typeable for")
1190                           <+> quotes (pprSourceTyCon tc)
1191                           <+> ptext (sLit "alone") ]
1192
1193 functorLikeClassKeys :: [Unique]
1194 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
1195
1196 cond_functorOK :: Bool -> Condition
1197 -- OK for Functor/Foldable/Traversable class
1198 -- Currently: (a) at least one argument
1199 --            (b) don't use argument contravariantly
1200 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
1201 --            (d) optionally: don't use function types
1202 --            (e) no "stupid context" on data type
1203 cond_functorOK allowFunctions (_, rep_tc, _)
1204   | null tc_tvs
1205   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1206           <+> ptext (sLit "must have some type parameters"))
1207
1208   | not (null bad_stupid_theta)
1209   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1210           <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
1211
1212   | otherwise
1213   = msum (map check_con data_cons)      -- msum picks the first 'Just', if any
1214   where
1215     tc_tvs            = tyConTyVars rep_tc
1216     Just (_, last_tv) = snocView tc_tvs
1217     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
1218     is_bad pred       = last_tv `elemVarSet` tyVarsOfType pred
1219
1220     data_cons = tyConDataCons rep_tc
1221     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
1222
1223     check_vanilla :: DataCon -> Maybe SDoc
1224     check_vanilla con | isVanillaDataCon con = Nothing
1225                       | otherwise            = Just (badCon con existential)
1226
1227     ft_check :: DataCon -> FFoldType (Maybe SDoc)
1228     ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
1229                       , ft_co_var = Just (badCon con covariant)
1230                       , ft_fun = \x y -> if allowFunctions then x `mplus` y
1231                                                            else Just (badCon con functions)
1232                       , ft_tup = \_ xs  -> msum xs
1233                       , ft_ty_app = \_ x   -> x
1234                       , ft_bad_app = Just (badCon con wrong_arg)
1235                       , ft_forall = \_ x   -> x }
1236
1237     existential = ptext (sLit "must not have existential arguments")
1238     covariant   = ptext (sLit "must not use the type variable in a function argument")
1239     functions   = ptext (sLit "must not contain function types")
1240     wrong_arg   = ptext (sLit "must use the type variable only as the last argument of a data type")
1241
1242 checkFlag :: ExtensionFlag -> Condition
1243 checkFlag flag (dflags, _, _)
1244   | xopt flag dflags = Nothing
1245   | otherwise        = Just why
1246   where
1247     why = ptext (sLit "You need -X") <> text flag_str
1248           <+> ptext (sLit "to derive an instance for this class")
1249     flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
1250                  [s]   -> s
1251                  other -> pprPanic "checkFlag" (ppr other)
1252
1253 std_class_via_iso :: Class -> Bool
1254 -- These standard classes can be derived for a newtype
1255 -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
1256 -- because giving so gives the same results as generating the boilerplate
1257 std_class_via_iso clas
1258   = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
1259         -- Not Read/Show because they respect the type
1260         -- Not Enum, because newtypes are never in Enum
1261
1262
1263 non_iso_class :: Class -> Bool
1264 -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by isomorphism,
1265 -- even with -XGeneralizedNewtypeDeriving
1266 non_iso_class cls
1267   = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
1268                          , genClassKey, gen1ClassKey, typeableClassKey]
1269                          ++ oldTypeableClassKeys)
1270
1271 oldTypeableClassKeys :: [Unique]
1272 oldTypeableClassKeys = map getUnique oldTypeableClassNames
1273
1274 new_dfun_name :: Class -> TyCon -> TcM Name
1275 new_dfun_name clas tycon        -- Just a simple wrapper
1276   = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
1277         ; newDFunName clas [mkTyConApp tycon []] loc }
1278         -- The type passed to newDFunName is only used to generate
1279         -- a suitable string; hence the empty type arg list
1280
1281 badCon :: DataCon -> SDoc -> SDoc
1282 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1283 \end{code}
1284
1285 Note [Superclasses of derived instance]
1286 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1287 In general, a derived instance decl needs the superclasses of the derived
1288 class too.  So if we have
1289         data T a = ...deriving( Ord )
1290 then the initial context for Ord (T a) should include Eq (T a).  Often this is
1291 redundant; we'll also generate an Ord constraint for each constructor argument,
1292 and that will probably generate enough constraints to make the Eq (T a) constraint
1293 be satisfied too.  But not always; consider:
1294
1295  data S a = S
1296  instance Eq (S a)
1297  instance Ord (S a)
1298
1299  data T a = MkT (S a) deriving( Ord )
1300  instance Num a => Eq (T a)
1301
1302 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1303 Similarly consider:
1304         data T a = MkT deriving( Data, Typeable )
1305 Here there *is* no argument field, but we must nevertheless generate
1306 a context for the Data instances:
1307         instance Typable a => Data (T a) where ...
1308
1309
1310 %************************************************************************
1311 %*                                                                      *
1312                 Deriving newtypes
1313 %*                                                                      *
1314 %************************************************************************
1315
1316 \begin{code}
1317 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1318              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1319              -> DerivContext
1320              -> TcRn EarlyDerivSpec
1321 mkNewTypeEqn orig dflags tvs
1322              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1323 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1324   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1325   = do  { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1326         ; dfun_name <- new_dfun_name cls tycon
1327         ; loc <- getSrcSpanM
1328         ; let spec = DS { ds_loc = loc, ds_orig = orig
1329                         , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
1330                         , ds_cls = cls, ds_tys = inst_tys
1331                         , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1332                         , ds_theta =  mtheta `orElse` all_preds
1333                         , ds_newtype = True }
1334         ; return (if isJust mtheta then Right spec
1335                                    else Left spec) }
1336
1337   | otherwise
1338   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
1339       CanDerive -> go_for_it    -- Use the standard H98 method
1340       DerivableClassError msg   -- Error with standard class
1341         | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
1342         | otherwise                  -> bale_out msg
1343       NonDerivableClass         -- Must use newtype deriving
1344         | newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
1345         | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1346         | otherwise                  -> bale_out non_std
1347   where
1348         newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1349         go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1350         bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1351
1352         non_std    = nonStdErr cls
1353         suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1354
1355         -- Here is the plan for newtype derivings.  We see
1356         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1357         -- where t is a type,
1358         --       ak+1...an is a suffix of a1..an, and are all tyars
1359         --       ak+1...an do not occur free in t, nor in the s1..sm
1360         --       (C s1 ... sm) is a  *partial applications* of class C
1361         --                      with the last parameter missing
1362         --       (T a1 .. ak) matches the kind of C's last argument
1363         --              (and hence so does t)
1364         -- The latter kind-check has been done by deriveTyData already,
1365         -- and tc_args are already trimmed
1366         --
1367         -- We generate the instance
1368         --       instance forall ({a1..ak} u fvs(s1..sm)).
1369         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
1370         -- where T a1...ap is the partial application of
1371         --       the LHS of the correct kind and p >= k
1372         --
1373         --      NB: the variables below are:
1374         --              tc_tvs = [a1, ..., an]
1375         --              tyvars_to_keep = [a1, ..., ak]
1376         --              rep_ty = t ak .. an
1377         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
1378         --              tys = [s1, ..., sm]
1379         --              rep_fn' = t
1380         --
1381         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1382         -- We generate the instance
1383         --      instance Monad (ST s) => Monad (T s) where
1384
1385         nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1386                 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1387                 -- eta-reduces the representation type, so we know that
1388                 --      T a ~ S a a
1389                 -- That's convenient here, because we may have to apply
1390                 -- it to fewer than its original complement of arguments
1391
1392         -- Note [Newtype representation]
1393         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1394         -- Need newTyConRhs (*not* a recursive representation finder)
1395         -- to get the representation type. For example
1396         --      newtype B = MkB Int
1397         --      newtype A = MkA B deriving( Num )
1398         -- We want the Num instance of B, *not* the Num instance of Int,
1399         -- when making the Num instance of A!
1400         rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1401         rep_tys     = cls_tys ++ [rep_inst_ty]
1402         rep_pred    = mkClassPred cls rep_tys
1403                 -- rep_pred is the representation dictionary, from where
1404                 -- we are gong to get all the methods for the newtype
1405                 -- dictionary
1406
1407
1408     -- Next we figure out what superclass dictionaries to use
1409     -- See Note [Newtype deriving superclasses] above
1410
1411         cls_tyvars = classTyVars cls
1412         dfun_tvs = tyVarsOfTypes inst_tys
1413         inst_ty = mkTyConApp tycon tc_args
1414         inst_tys = cls_tys ++ [inst_ty]
1415         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1416                               (classSCTheta cls)
1417
1418                 -- If there are no tyvars, there's no need
1419                 -- to abstract over the dictionaries we need
1420                 -- Example:     newtype T = MkT Int deriving( C )
1421                 -- We get the derived instance
1422                 --              instance C T
1423                 -- rather than
1424                 --              instance C Int => C T
1425         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
1426
1427         -------------------------------------------------------------------
1428         --  Figuring out whether we can only do this newtype-deriving thing
1429
1430         can_derive_via_isomorphism
1431            =  not (non_iso_class cls)
1432            && arity_ok
1433            && eta_ok
1434            && ats_ok
1435 --         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
1436
1437         arity_ok = length cls_tys + 1 == classArity cls
1438                 -- Well kinded; eg not: newtype T ... deriving( ST )
1439                 --                      because ST needs *2* type params
1440
1441         -- Check that eta reduction is OK
1442         eta_ok = nt_eta_arity <= length rep_tc_args
1443                 -- The newtype can be eta-reduced to match the number
1444                 --     of type argument actually supplied
1445                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
1446                 --     Here the 'b' must be the same in the rep type (S [a] b)
1447                 --     And the [a] must not mention 'b'.  That's all handled
1448                 --     by nt_eta_rity.
1449
1450         ats_ok = null (classATs cls)
1451                -- No associated types for the class, because we don't
1452                -- currently generate type 'instance' decls; and cannot do
1453                -- so for 'data' instance decls
1454
1455         cant_derive_err
1456            = vcat [ ppUnless arity_ok arity_msg
1457                   , ppUnless eta_ok eta_msg
1458                   , ppUnless ats_ok ats_msg ]
1459         arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1460         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
1461         ats_msg   = ptext (sLit "the class has associated types")
1462 \end{code}
1463
1464 Note [Recursive newtypes]
1465 ~~~~~~~~~~~~~~~~~~~~~~~~~
1466 Newtype deriving works fine, even if the newtype is recursive.
1467 e.g.    newtype S1 = S1 [T1 ()]
1468         newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1469 Remember, too, that type families are curretly (conservatively) given
1470 a recursive flag, so this also allows newtype deriving to work
1471 for type famillies.
1472
1473 We used to exclude recursive types, because we had a rather simple
1474 minded way of generating the instance decl:
1475    newtype A = MkA [A]
1476    instance Eq [A] => Eq A      -- Makes typechecker loop!
1477 But now we require a simple context, so it's ok.
1478
1479
1480 %************************************************************************
1481 %*                                                                      *
1482 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1483 %*                                                                      *
1484 %************************************************************************
1485
1486 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1487 terms, which is the final correct RHS for the corresponding original
1488 equation.
1489 \begin{itemize}
1490 \item
1491 Each (k,TyVarTy tv) in a solution constrains only a type
1492 variable, tv.
1493
1494 \item
1495 The (k,TyVarTy tv) pairs in a solution are canonically
1496 ordered by sorting on type varible, tv, (major key) and then class, k,
1497 (minor key)
1498 \end{itemize}
1499
1500 \begin{code}
1501 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1502
1503 inferInstanceContexts _ [] = return []
1504
1505 inferInstanceContexts oflag infer_specs
1506   = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1507         ; iterate_deriv 1 initial_solutions }
1508   where
1509     ------------------------------------------------------------------
1510         -- The initial solutions for the equations claim that each
1511         -- instance has an empty context; this solution is certainly
1512         -- in canonical form.
1513     initial_solutions :: [ThetaType]
1514     initial_solutions = [ [] | _ <- infer_specs ]
1515
1516     ------------------------------------------------------------------
1517         -- iterate_deriv calculates the next batch of solutions,
1518         -- compares it with the current one; finishes if they are the
1519         -- same, otherwise recurses with the new solutions.
1520         -- It fails if any iteration fails
1521     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1522     iterate_deriv n current_solns
1523       | n > 20  -- Looks as if we are in an infinite loop
1524                 -- This can happen if we have -XUndecidableInstances
1525                 -- (See TcSimplify.tcSimplifyDeriv.)
1526       = pprPanic "solveDerivEqns: probable loop"
1527                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1528       | otherwise
1529       = do {      -- Extend the inst info from the explicit instance decls
1530                   -- with the current set of solutions, and simplify each RHS
1531              inst_specs <- zipWithM (mkInstance oflag) current_solns infer_specs
1532            ; new_solns <- checkNoErrs $
1533                           extendLocalInstEnv inst_specs $
1534                           mapM gen_soln infer_specs
1535
1536            ; let eqList :: (a -> b -> Bool) -> [a] -> [b] -> Bool
1537                  eqList f xs ys = length xs == length ys && and (zipWith f xs ys)
1538
1539            ; if (eqList (eqList eqType) current_solns new_solns) then
1540                 return [ spec { ds_theta = soln }
1541                        | (spec, soln) <- zip infer_specs current_solns ]
1542              else
1543                 iterate_deriv (n+1) new_solns }
1544
1545     ------------------------------------------------------------------
1546     gen_soln :: DerivSpec  -> TcM [PredType]
1547     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1548                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1549       = setSrcSpan loc  $
1550         addErrCtxt (derivInstCtxt the_pred) $
1551         do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
1552                 -- checkValidInstance tyvars theta clas inst_tys
1553                 -- Not necessary; see Note [Exotic derived instance contexts]
1554                 --                in TcSimplify
1555
1556            ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1557                 -- Claim: the result instance declaration is guaranteed valid
1558                 -- Hence no need to call:
1559                 --   checkValidInstance tyvars theta clas inst_tys
1560            ; return (sortBy cmpType theta) }    -- Canonicalise before returning the solution
1561       where
1562         the_pred = mkClassPred clas inst_tys
1563
1564 ------------------------------------------------------------------
1565 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> TcM ClsInst
1566 mkInstance overlap_flag theta
1567            (DS { ds_name = dfun_name
1568                , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
1569   = do { (subst, tvs') <- tcInstSkolTyVars tvs
1570        ; return (mkLocalInstance dfun overlap_flag tvs' clas (substTys subst tys)) }
1571   where
1572     dfun = mkDictFunId dfun_name tvs theta clas tys
1573
1574
1575 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
1576 -- Add new locally-defined instances; don't bother to check
1577 -- for functional dependency errors -- that'll happen in TcInstDcls
1578 extendLocalInstEnv dfuns thing_inside
1579  = do { env <- getGblEnv
1580       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1581              env'      = env { tcg_inst_env = inst_env' }
1582       ; setGblEnv env' thing_inside }
1583 \end{code}
1584
1585
1586 ***********************************************************************************
1587 *                                                                                 * 
1588 *            Simplify derived constraints
1589 *                                                                                 *
1590 ***********************************************************************************
1591
1592 \begin{code}
1593 simplifyDeriv :: CtOrigin
1594               -> PredType
1595               -> [TyVar]        
1596               -> ThetaType              -- Wanted
1597               -> TcM ThetaType  -- Needed
1598 -- Given  instance (wanted) => C inst_ty 
1599 -- Simplify 'wanted' as much as possibles
1600 -- Fail if not possible
1601 simplifyDeriv orig pred tvs theta 
1602   = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
1603                 -- The constraint solving machinery 
1604                 -- expects *TcTyVars* not TyVars.  
1605                 -- We use *non-overlappable* (vanilla) skolems
1606                 -- See Note [Overlap and deriving]
1607
1608        ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
1609              skol_set   = mkVarSet tvs_skols
1610              doc = ptext (sLit "deriving") <+> parens (ppr pred)
1611
1612        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
1613
1614        ; traceTc "simplifyDeriv" $ 
1615          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
1616        ; (residual_wanted, _ev_binds1)
1617              <- solveWantedsTcM (mkFlatWC wanted)
1618                 -- Post: residual_wanted are already zonked
1619
1620        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
1621                          -- See Note [Exotic derived instance contexts]
1622              get_good :: Ct -> Either PredType Ct
1623              get_good ct | validDerivPred skol_set p 
1624                          , isWantedCt ct  = Left p 
1625                          -- NB: residual_wanted may contain unsolved
1626                          -- Derived and we stick them into the bad set
1627                          -- so that reportUnsolved may decide what to do with them
1628                          | otherwise = Right ct
1629                          where p = ctPred ct
1630
1631        -- We never want to defer these errors because they are errors in the
1632        -- compiler! Hence the `False` below
1633        ; reportAllUnsolved (residual_wanted { wc_flat = bad })
1634
1635        ; let min_theta = mkMinimalBySCs (bagToList good)
1636        ; return (substTheta subst_skol min_theta) }
1637 \end{code}
1638
1639 Note [Overlap and deriving]
1640 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1641 Consider some overlapping instances:
1642   data Show a => Show [a] where ..
1643   data Show [Char] where ...
1644
1645 Now a data type with deriving:
1646   data T a = MkT [a] deriving( Show )
1647
1648 We want to get the derived instance
1649   instance Show [a] => Show (T a) where...
1650 and NOT
1651   instance Show a => Show (T a) where...
1652 so that the (Show (T Char)) instance does the Right Thing
1653
1654 It's very like the situation when we're inferring the type
1655 of a function
1656    f x = show [x]
1657 and we want to infer
1658    f :: Show [a] => a -> String
1659
1660 BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
1661              the context for the derived instance. 
1662              Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
1663
1664 Note [Exotic derived instance contexts]
1665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1666 In a 'derived' instance declaration, we *infer* the context.  It's a
1667 bit unclear what rules we should apply for this; the Haskell report is
1668 silent.  Obviously, constraints like (Eq a) are fine, but what about
1669         data T f a = MkT (f a) deriving( Eq )
1670 where we'd get an Eq (f a) constraint.  That's probably fine too.
1671
1672 One could go further: consider
1673         data T a b c = MkT (Foo a b c) deriving( Eq )
1674         instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
1675
1676 Notice that this instance (just) satisfies the Paterson termination 
1677 conditions.  Then we *could* derive an instance decl like this:
1678
1679         instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
1680 even though there is no instance for (C Int a), because there just
1681 *might* be an instance for, say, (C Int Bool) at a site where we
1682 need the equality instance for T's.  
1683
1684 However, this seems pretty exotic, and it's quite tricky to allow
1685 this, and yet give sensible error messages in the (much more common)
1686 case where we really want that instance decl for C.
1687
1688 So for now we simply require that the derived instance context
1689 should have only type-variable constraints.
1690
1691 Here is another example:
1692         data Fix f = In (f (Fix f)) deriving( Eq )
1693 Here, if we are prepared to allow -XUndecidableInstances we
1694 could derive the instance
1695         instance Eq (f (Fix f)) => Eq (Fix f)
1696 but this is so delicate that I don't think it should happen inside
1697 'deriving'. If you want this, write it yourself!
1698
1699 NB: if you want to lift this condition, make sure you still meet the
1700 termination conditions!  If not, the deriving mechanism generates
1701 larger and larger constraints.  Example:
1702   data Succ a = S a
1703   data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
1704
1705 Note the lack of a Show instance for Succ.  First we'll generate
1706   instance (Show (Succ a), Show a) => Show (Seq a)
1707 and then
1708   instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
1709 and so on.  Instead we want to complain of no instance for (Show (Succ a)).
1710
1711 The bottom line
1712 ~~~~~~~~~~~~~~~
1713 Allow constraints which consist only of type variables, with no repeats.
1714
1715
1716 %************************************************************************
1717 %*                                                                      *
1718 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1719 %*                                                                      *
1720 %************************************************************************
1721
1722 After all the trouble to figure out the required context for the
1723 derived instance declarations, all that's left is to chug along to
1724 produce them.  They will then be shoved into @tcInstDecls2@, which
1725 will do all its usual business.
1726
1727 There are lots of possibilities for code to generate.  Here are
1728 various general remarks.
1729
1730 PRINCIPLES:
1731 \begin{itemize}
1732 \item
1733 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1734 ``you-couldn't-do-better-by-hand'' efficient.
1735
1736 \item
1737 Deriving @Show@---also pretty common--- should also be reasonable good code.
1738
1739 \item
1740 Deriving for the other classes isn't that common or that big a deal.
1741 \end{itemize}
1742
1743 PRAGMATICS:
1744
1745 \begin{itemize}
1746 \item
1747 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1748
1749 \item
1750 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1751
1752 \item
1753 We {\em normally} generate code only for the non-defaulted methods;
1754 there are some exceptions for @Eq@ and (especially) @Ord@...
1755
1756 \item
1757 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1758 constructor's numeric (@Int#@) tag.  These are generated by
1759 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1760 these is around is given by @hasCon2TagFun@.
1761
1762 The examples under the different sections below will make this
1763 clearer.
1764
1765 \item
1766 Much less often (really just for deriving @Ix@), we use a
1767 @_tag2con_<tycon>@ function.  See the examples.
1768
1769 \item
1770 We use the renamer!!!  Reason: we're supposed to be
1771 producing @LHsBinds Name@ for the methods, but that means
1772 producing correctly-uniquified code on the fly.  This is entirely
1773 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1774 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1775 the renamer.  What a great hack!
1776 \end{itemize}
1777
1778 \begin{code}
1779 -- Generate the InstInfo for the required instance paired with the
1780 --   *representation* tycon for that instance,
1781 -- plus any auxiliary bindings required
1782 --
1783 -- Representation tycons differ from the tycon in the instance signature in
1784 -- case of instances for indexed families.
1785 --
1786 genInst :: Bool             -- True <=> standalone deriving
1787         -> OverlapFlag
1788         -> CommonAuxiliaries
1789         -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
1790 genInst standalone_deriv oflag comauxs
1791         spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1792                  , ds_theta = theta, ds_newtype = is_newtype
1793                  , ds_name = name, ds_cls = clas })
1794   | is_newtype
1795   = do { inst_spec <- mkInstance oflag theta spec
1796        ; return (InstInfo { iSpec   = inst_spec
1797                           , iBinds  = NewTypeDerived co rep_tycon }, emptyBag) }
1798
1799   | otherwise
1800   = do { fix_env <- getFixityEnv
1801        ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
1802                                         fix_env clas name rep_tycon
1803                                         (lookup rep_tycon comauxs)
1804        ; inst_spec <- mkInstance oflag theta spec
1805        ; let inst_info = InstInfo { iSpec   = inst_spec
1806                                   , iBinds  = VanillaInst meth_binds []
1807                                                 standalone_deriv }
1808        ; return ( inst_info, deriv_stuff) }
1809   where
1810     co1 = case tyConFamilyCoercion_maybe rep_tycon of
1811               Just co_con -> mkTcUnbranchedAxInstCo co_con rep_tc_args
1812               Nothing     -> id_co
1813               -- Not a family => rep_tycon = main tycon
1814     co2 = mkTcUnbranchedAxInstCo (newTyConCo rep_tycon) rep_tc_args
1815     co  = mkTcForAllCos tvs (co1 `mkTcTransCo` co2)
1816     id_co = mkTcReflCo (mkTyConApp rep_tycon rep_tc_args)
1817
1818 -- Example: newtype instance N [a] = N1 (Tree a)
1819 --          deriving instance Eq b => Eq (N [(b,b)])
1820 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1821 -- When dealing with the deriving clause
1822 --    co1 : N [(b,b)] ~ R1:N (b,b)
1823 --    co2 : R1:N (b,b) ~ Tree (b,b)
1824 --    co  : N [(b,b)] ~ Tree (b,b)
1825
1826 genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
1827               -> Maybe CommonAuxiliary
1828               -> TcM (LHsBinds RdrName, BagDerivStuff)
1829 genDerivStuff loc fix_env clas name tycon comaux_maybe
1830   | className clas `elem` oldTypeableClassNames
1831   = do dflags <- getDynFlags
1832        return (gen_old_Typeable_binds dflags loc tycon, emptyBag)
1833
1834   | className clas == typeableClassName
1835   = do dflags <- getDynFlags
1836        return (gen_Typeable_binds dflags loc tycon, emptyBag)
1837
1838   | ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
1839   = let gk =  if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One
1840         Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
1841     in do
1842       (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name)
1843       return (binds, DerivFamInst faminst `consBag` emptyBag)
1844
1845   | otherwise                      -- Non-monadic generators
1846   = do dflags <- getDynFlags
1847        case assocMaybe (gen_list dflags) (getUnique clas) of
1848         Just gen_fn -> return (gen_fn loc tycon)
1849         Nothing     -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
1850   where
1851     ck = classKey clas
1852
1853     gen_list :: DynFlags
1854              -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
1855     gen_list dflags
1856              = [(eqClassKey, gen_Eq_binds)
1857                ,(ordClassKey, gen_Ord_binds)
1858                ,(enumClassKey, gen_Enum_binds)
1859                ,(boundedClassKey, gen_Bounded_binds)
1860                ,(ixClassKey, gen_Ix_binds)
1861                ,(showClassKey, gen_Show_binds fix_env)
1862                ,(readClassKey, gen_Read_binds fix_env)
1863                ,(dataClassKey, gen_Data_binds dflags)
1864                ,(functorClassKey, gen_Functor_binds)
1865                ,(foldableClassKey, gen_Foldable_binds)
1866                ,(traversableClassKey, gen_Traversable_binds)
1867                ]
1868 \end{code}
1869
1870 %************************************************************************
1871 %*                                                                      *
1872 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1873 %*                                                                      *
1874 %************************************************************************
1875
1876 \begin{code}
1877 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc
1878 derivingKindErr tc cls cls_tys cls_kind
1879   = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1880                 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1881        2 (ptext (sLit "Class") <+> quotes (ppr cls)
1882             <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1883
1884 derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
1885 derivingEtaErr cls cls_tys inst_ty
1886   = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1887          nest 2 (ptext (sLit "instance (...) =>")
1888                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1889
1890 derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc
1891 derivingThingErr newtype_deriving clas tys ty why
1892   = sep [(hang (ptext (sLit "Can't make a derived instance of"))
1893              2 (quotes (ppr pred))
1894           $$ nest 2 extra) <> colon,
1895          nest 2 why]
1896   where
1897     extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
1898           | otherwise        = empty
1899     pred = mkClassPred clas (tys ++ [ty])
1900
1901 derivingHiddenErr :: TyCon -> SDoc
1902 derivingHiddenErr tc
1903   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1904        2 (ptext (sLit "so you cannot derive an instance for it"))
1905
1906 standaloneCtxt :: LHsType Name -> SDoc
1907 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1908                        2 (quotes (ppr ty))
1909
1910 derivInstCtxt :: PredType -> MsgDoc
1911 derivInstCtxt pred
1912   = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
1913 \end{code}