76a901115b1fcc7169a14aa462c7bba0ce866098
[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
32 import RnBinds
33 import RnEnv
34 import RnSource   ( addTcgDUs )
35 import HscTypes
36
37 import Unify( tcMatchTy )
38 import Id( idType )
39 import Class
40 import Type
41 import Kind( isKind )
42 import ErrUtils
43 import MkId
44 import DataCon
45 import Maybes
46 import RdrName
47 import Name
48 import NameSet
49 import TyCon
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 Coercible; it shows
278         Foo 3 as "Foo 3"
279 The Num instance is derived via Coercible, 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 . fstOf3) 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, maybe_fvs) = unzip3 (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         ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
354         ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
355   where
356     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
357                    -> Bag TyCon                 -- ^ Empty data constructors
358                    -> Bag (FamInst)             -- ^ 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 -> SDoc
374 pprRepTy fi@(FamInst { fi_tys = lhs })
375   = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
376       equals <+> ppr rhs
377   where rhs = famInstRHS fi
378
379 -- As of 24 April 2012, this only shares MetaTyCons between derivations of
380 -- Generic and Generic1; thus the types and logic are quite simple.
381 type CommonAuxiliary = MetaTyCons
382 type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
383 commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff)
384 commonAuxiliaries = foldM snoc ([], emptyBag) where
385   snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
386     | getUnique cls `elem` [genClassKey, gen1ClassKey] =
387       extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
388     | otherwise = return acc
389    where extendComAux m -- don't run m if its already in the accumulator
390            | any ((rep_tycon ==) . fst) cas = return acc
391            | otherwise = do (ca, new_stuff) <- m
392                             return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
393
394 renameDeriv :: Bool
395             -> [InstInfo RdrName]
396             -> Bag (LHsBind RdrName, LSig RdrName)
397             -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
398 renameDeriv is_boot inst_infos bagBinds
399   | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
400                 -- The inst-info bindings will all be empty, but it's easier to
401                 -- just use rn_inst_info to change the type appropriately
402   = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
403         ; return ( listToBag rn_inst_infos
404                  , emptyValBindsOut, usesOnly (plusFVs fvs)) }
405
406   | otherwise
407   = discardWarnings $         -- Discard warnings about unused bindings etc
408     setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have
409                               --    case x of {}
410     setXOptM Opt_ScopedTypeVariables $  -- Derived decls (for newtype-deriving) can
411     setXOptM Opt_KindSignatures $       -- used ScopedTypeVariables & KindSignatures
412     do  {
413         -- Bring the extra deriving stuff into scope
414         -- before renaming the instances themselves
415         ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
416         ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
417         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
418         ; let bndrs = collectHsValBinders rn_aux_lhs
419         ; bindLocalNames bndrs $
420     do  { (rn_aux, dus_aux) <- rnValBindsRHS (LocalBindCtxt (mkNameSet bndrs)) rn_aux_lhs
421         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
422         ; return (listToBag rn_inst_infos, rn_aux,
423                   dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
424
425   where
426     rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
427     rn_inst_info inst_info@(InstInfo { iSpec = inst
428                                      , iBinds = InstBindings
429                                                   { ib_binds = binds
430                                                   , ib_pragmas = sigs
431                                                   , ib_standalone_deriving = sa } })
432         =       -- Bring the right type variables into
433                 -- scope (yuk), and rename the method binds
434            ASSERT( null sigs )
435            bindLocalNamesFV (map Var.varName tyvars) $
436            do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
437               ; let binds' = InstBindings { ib_binds = rn_binds
438                                            , ib_pragmas = []
439                                            , ib_standalone_deriving = sa }
440               ; return (inst_info { iBinds = binds' }, fvs) }
441         where
442           (tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
443 \end{code}
444
445 Note [Newtype deriving and unused constructors]
446 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
447 Consider this (see Trac #1954):
448
449   module Bug(P) where
450   newtype P a = MkP (IO a) deriving Monad
451
452 If you compile with -fwarn-unused-binds you do not expect the warning
453 "Defined but not used: data consructor MkP". Yet the newtype deriving
454 code does not explicitly mention MkP, but it should behave as if you
455 had written
456   instance Monad P where
457      return x = MkP (return x)
458      ...etc...
459
460 So we want to signal a user of the data constructor 'MkP'.
461 This is the reason behind the (Maybe Name) part of the return type
462 of genInst.
463
464 %************************************************************************
465 %*                                                                      *
466                 From HsSyn to DerivSpec
467 %*                                                                      *
468 %************************************************************************
469
470 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
471
472 \begin{code}
473 makeDerivSpecs :: Bool
474                -> [LTyClDecl Name]
475                -> [LInstDecl Name]
476                -> [LDerivDecl Name]
477                -> TcM [EarlyDerivSpec]
478 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
479   = do  { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl)   tycl_decls
480         ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls
481         ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls
482         ; let eqns = eqns1 ++ eqns2 ++ eqns3
483
484         -- If AutoDeriveTypeable is set, we automatically add Typeable instances
485         -- for every data type and type class declared in the module
486         ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable
487         ; let eqns4 = if isAutoTypeable then deriveTypeable tycl_decls eqns else []
488         ; eqns4' <- mapAndRecoverM deriveStandalone eqns4
489         ; let eqns' = eqns ++ eqns4'
490
491         ; if is_boot then   -- No 'deriving' at all in hs-boot files
492               do { unless (null eqns') (add_deriv_err (head eqns'))
493                  ; return [] }
494           else return eqns' }
495   where
496     deriveTypeable :: [LTyClDecl Name] -> [EarlyDerivSpec] -> [LDerivDecl Name]
497     deriveTypeable tys dss =
498       [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
499                                      (L l (HsTyVar (tcdName t))))))
500       | L l t <- tys
501         -- Don't add Typeable instances for type synonyms and type families
502       , not (isSynDecl t), not (isTypeFamilyDecl t)
503         -- ... nor if the user has already given a deriving clause
504       , not (hasInstance (tcdName t) dss) ]
505
506     -- Check if an automatically generated DS for deriving Typeable should be
507     -- ommitted because the user had manually requested for an instance
508     hasInstance :: Name -> [EarlyDerivSpec] -> Bool
509     hasInstance n = any (\ds -> n == tyConName (either ds_tc ds_tc ds))
510
511     add_deriv_err eqn
512        = setSrcSpan (either ds_loc ds_loc eqn) $
513          addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
514                     2 (ptext (sLit "Use an instance declaration instead")))
515
516 ------------------------------------------------------------------
517 deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
518 deriveTyDecl (L _ decl@(DataDecl { tcdLName = L loc tc_name
519                                  , tcdDataDefn = HsDataDefn { dd_derivs = preds } }))
520   = tcAddDeclCtxt decl $
521     do { tc <- tcLookupTyCon tc_name
522        ; let tvs  = tyConTyVars tc
523              tys  = mkTyVarTys tvs
524              pdcs :: [LDerivDecl Name]
525              pdcs = [ L loc (DerivDecl (L loc (HsAppTy (noLoc (HsTyVar typeableClassName))
526                                        (L loc (HsTyVar (tyConName pdc))))))
527                     | Just pdc <- map promoteDataCon_maybe (tyConDataCons tc) ]
528         -- If AutoDeriveTypeable and DataKinds is set, we add Typeable instances
529         -- for every promoted data constructor of datatypes in this module
530        ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable
531        ; isDataKinds    <- xoptM Opt_DataKinds
532        ; prom_dcs_Typeable_instances <- if isAutoTypeable && isDataKinds
533                                         then mapM deriveStandalone pdcs
534                                         else return []
535        ; other_instances <- case preds of
536                               Just preds' -> mapM (deriveTyData tvs tc tys) preds'
537                               Nothing     -> return []
538        ; return (prom_dcs_Typeable_instances ++ other_instances) }
539
540 deriveTyDecl _ = return []
541
542 ------------------------------------------------------------------
543 deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
544 deriveInstDecl (L _ (TyFamInstD {})) = return []
545 deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
546   = deriveFamInst fam_inst
547 deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
548   = concatMapM (deriveFamInst . unLoc) fam_insts
549
550 ------------------------------------------------------------------
551 deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
552 deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
553                                     , dfid_defn = HsDataDefn { dd_derivs = Just preds } })
554   = tcAddDataFamInstCtxt decl $
555     do { fam_tc <- tcLookupTyCon tc_name
556        ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $
557          \ tvs' pats' _ ->
558            mapM (deriveTyData tvs' fam_tc pats') preds }
559         -- Tiresomely we must figure out the "lhs", which is awkward for type families
560         -- E.g.   data T a b = .. deriving( Eq )
561         --          Here, the lhs is (T a b)
562         --        data instance TF Int b = ... deriving( Eq )
563         --          Here, the lhs is (TF Int b)
564         -- But if we just look up the tycon_name, we get is the *family*
565         -- tycon, but not pattern types -- they are in the *rep* tycon.
566
567 deriveFamInst _ = return []
568
569 ------------------------------------------------------------------
570 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
571 -- Standalone deriving declarations
572 --  e.g.   deriving instance Show a => Show (T a)
573 -- Rather like tcLocalInstDecl
574 deriveStandalone (L loc (DerivDecl deriv_ty))
575   = setSrcSpan loc                   $
576     addErrCtxt (standaloneCtxt deriv_ty)  $
577     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
578        ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
579        ; traceTc "Standalone deriving;" $ vcat
580               [ text "tvs:" <+> ppr tvs
581               , text "theta:" <+> ppr theta
582               , text "cls:" <+> ppr cls
583               , text "tys:" <+> ppr inst_tys ]
584                 -- C.f. TcInstDcls.tcLocalInstDecl1
585        ; checkTc (not (null inst_tys)) derivingNullaryErr
586
587        ; let cls_tys = take (length inst_tys - 1) inst_tys
588              inst_ty = last inst_tys
589        ; traceTc "Standalone deriving:" $ vcat
590               [ text "class:" <+> ppr cls
591               , text "class types:" <+> ppr cls_tys
592               , text "type:" <+> ppr inst_ty ]
593
594        ; case tcSplitTyConApp_maybe inst_ty of
595            Just (tycon, tc_args)
596               | className cls == typeableClassName || isAlgTyCon tycon
597               -> mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys
598                            tycon tc_args (Just theta)
599
600            _  -> -- Complain about functions, primitive types, etc,
601                  -- except for the Typeable class
602                  failWithTc $ derivingThingErr False cls cls_tys inst_ty $
603                  ptext (sLit "The last argument of the instance must be a data or newtype application")
604         }
605
606 ------------------------------------------------------------------
607 deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
608              -> LHsType Name                 -- The deriving predicate
609              -> TcM EarlyDerivSpec
610 -- The deriving clause of a data or newtype declaration
611 deriveTyData tvs tc tc_args (L loc deriv_pred)
612   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
613     do  { (deriv_tvs, cls, cls_tys) <- tcExtendTyVarEnv tvs $
614                                        tcHsDeriv deriv_pred
615                 -- Deriving preds may (now) mention
616                 -- the type variables for the type constructor, hence tcExtendTyVarenv
617                 -- The "deriv_pred" is a LHsType to take account of the fact that for
618                 -- newtype deriving we allow deriving (forall a. C [a]).
619
620                 -- Typeable is special, becuase Typeable :: forall k. k -> Constraint
621                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
622                 -- as is the case for all other derivable type classes
623         ; if className cls == typeableClassName
624           then derivePolyKindedTypeable cls cls_tys tvs tc tc_args
625           else do {
626
627         -- Given data T a b c = ... deriving( C d ),
628         -- we want to drop type variables from T so that (C d (T a)) is well-kinded
629         ; let cls_tyvars     = classTyVars cls
630         ; checkTc (not (null cls_tyvars)) derivingNullaryErr
631
632         ; let kind            = tyVarKind (last cls_tyvars)
633               (arg_kinds, _)  = splitKindFunTys kind
634               n_args_to_drop  = length arg_kinds
635               n_args_to_keep  = tyConArity tc - n_args_to_drop
636               args_to_drop    = drop n_args_to_keep tc_args
637               tc_args_to_keep = take n_args_to_keep tc_args
638               inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
639               dropped_tvs     = tyVarsOfTypes args_to_drop
640               tv_set          = mkVarSet tvs
641               mb_match        = tcMatchTy tv_set inst_ty_kind kind
642               Just subst      = mb_match   -- See Note [Match kinds in deriving]
643
644               final_tc_args   = substTys subst tc_args_to_keep
645               univ_tvs        = mkVarSet deriv_tvs `unionVarSet` tyVarsOfTypes final_tc_args
646
647         ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args
648                                        , pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args)
649                                        , ppr n_args_to_keep, ppr n_args_to_drop
650                                        , ppr inst_ty_kind, ppr kind, ppr mb_match ])
651
652         -- Check that the result really is well-kinded
653         ; checkTc (n_args_to_keep >= 0 && isJust mb_match)
654                   (derivingKindErr tc cls cls_tys kind)
655
656         ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ])
657
658         ; checkTc (allDistinctTyVars args_to_drop &&            -- (a) and (b)
659                    univ_tvs `disjointVarSet` dropped_tvs)       -- (c)
660                   (derivingEtaErr cls cls_tys (mkTyConApp tc final_tc_args))
661                 -- Check that
662                 --  (a) The args to drop are all type variables; eg reject:
663                 --              data instance T a Int = .... deriving( Monad )
664                 --  (b) The args to drop are all *distinct* type variables; eg reject:
665                 --              class C (a :: * -> * -> *) where ...
666                 --              data instance T a a = ... deriving( C )
667                 --  (c) The type class args, or remaining tycon args,
668                 --      do not mention any of the dropped type variables
669                 --              newtype T a s = ... deriving( ST s )
670                 --              newtype K a a = ... deriving( Monad )
671
672         ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs)
673                     cls cls_tys tc final_tc_args Nothing } }
674
675 derivePolyKindedTypeable :: Class -> [Type]
676                          -> [TyVar] -> TyCon -> [Type]
677                          -> TcM EarlyDerivSpec
678 derivePolyKindedTypeable cls cls_tys _tvs tc tc_args
679   = do { checkTc (isSingleton cls_tys) $   -- Typeable k
680          derivingThingErr False cls cls_tys (mkTyConApp tc tc_args)
681                           (classArgsErr cls cls_tys)
682
683        -- Check that we have not said, for example
684        --       deriving Typeable (T Int)
685        -- or    deriving Typeable (S :: * -> *)     where S is kind-polymorphic
686        ; checkTc (allDistinctTyVars tc_args) $
687          derivingEtaErr cls cls_tys (mkTyConApp tc tc_kind_args)
688
689        ; mkEqnHelp DerivOrigin kind_vars cls cls_tys tc tc_kind_args Nothing }
690   where
691     kind_vars    = kindVarsOnly tc_args
692     tc_kind_args = mkTyVarTys kind_vars
693
694     kindVarsOnly :: [Type] -> [KindVar]
695     kindVarsOnly [] = []
696     kindVarsOnly (t:ts) | Just v <- getTyVar_maybe t
697                         , isKindVar v = v : kindVarsOnly ts
698                         | otherwise   =     kindVarsOnly ts
699 \end{code}
700
701 Note [Match kinds in deriving]
702 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
703 Consider (Trac #8534)
704     data T a b = MkT a deriving( Functor )
705     -- where Functor :: (*->*) -> Constraint
706
707 So T :: forall k. * -> k -> *.   We want to get
708     instance Functor (T * (a:*)) where ...
709 Notice the '*' argument to T.
710
711 So we need to (a) drop arguments from (T a b) to match the number of
712 arrows in the (last argument of the) class; and then match kind of the
713 remaining type against the expected kind, to figur out how to
714 instantiate T's kind arguments.  Hence we match 
715    kind( T k (a:k) ) ~ (* -> *)
716 to find k:=*.  Tricky stuff.
717
718
719 \begin{code}
720 mkEqnHelp :: CtOrigin -> [TyVar]
721           -> Class -> [Type]
722           -> TyCon -> [Type]
723           -> DerivContext       -- Just    => context supplied (standalone deriving)
724                                 -- Nothing => context inferred (deriving on data decl)
725           -> TcRn EarlyDerivSpec
726 -- Make the EarlyDerivSpec for an instance
727 --      forall tvs. theta => cls (tys ++ [ty])
728 -- where the 'theta' is optional (that's the Maybe part)
729 -- Assumes that this declaration is well-kinded
730
731 mkEqnHelp orig tvs cls cls_tys tycon tc_args mtheta
732   | className cls `elem` oldTypeableClassNames
733   = do { dflags <- getDynFlags
734        ; case checkOldTypeableConditions (dflags, tycon, tc_args) of
735            Just err -> bale_out err
736            Nothing  -> mkOldTypeableEqn orig tvs cls tycon tc_args mtheta }
737
738   | className cls == typeableClassName  -- Polykinded Typeable
739   = do { dflags <- getDynFlags
740        ; case checkTypeableConditions (dflags, tycon, tc_args) of
741            Just err -> bale_out err
742            Nothing  -> mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta }
743
744   | otherwise
745   = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args
746               -- Be careful to test rep_tc here: in the case of families,
747               -- we want to check the instance tycon, not the family tycon
748
749        -- For standalone deriving (mtheta /= Nothing),
750        -- check that all the data constructors are in scope.
751        ; rdr_env <- getGlobalRdrEnv
752        ; let data_con_names = map dataConName (tyConDataCons rep_tc)
753              hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
754                                 (isAbstractTyCon rep_tc ||
755                                  any not_in_scope data_con_names)
756              not_in_scope dc  = null (lookupGRE_Name rdr_env dc)
757
758              -- Make a Qual RdrName that will do for each DataCon
759              -- so we can report it as used (Trac #7969)
760              data_con_rdrs = [ mkRdrQual (is_as (is_decl imp_spec)) occ
761                              | dc_name <- data_con_names
762                              , let occ  = nameOccName dc_name
763                                    gres = lookupGRE_Name rdr_env dc_name
764                              , not (null gres)
765                              , Imported (imp_spec:_) <- [gre_prov (head gres)] ]
766
767        ; addUsedRdrNames data_con_rdrs
768        ; unless (isNothing mtheta || not hidden_data_cons)
769                 (bale_out (derivingHiddenErr tycon))
770
771        ; dflags <- getDynFlags
772        ; if isDataTyCon rep_tc then
773             mkDataTypeEqn orig dflags tvs cls cls_tys
774                           tycon tc_args rep_tc rep_tc_args mtheta
775          else
776             mkNewTypeEqn orig dflags tvs cls cls_tys
777                          tycon tc_args rep_tc rep_tc_args mtheta }
778   where
779      bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
780
781      lookup_data_fam :: TyCon -> [Type] -> TcM (TyCon, [Type])
782      -- Find the instance of a data family
783      -- Note [Looking up family instances for deriving]
784      lookup_data_fam tycon tys
785        | not (isFamilyTyCon tycon)
786        = return (tycon, tys)
787        | otherwise
788        = ASSERT( isAlgTyCon tycon )
789          do { maybeFamInst <- tcLookupFamInst tycon tys
790             ; case maybeFamInst of
791                 Nothing -> bale_out (ptext (sLit "No family instance for")
792                                      <+> quotes (pprTypeApp tycon tys))
793                 Just (FamInstMatch { fim_instance = famInst
794                                    , fim_tys      = tys })
795                   -> let tycon' = dataFamInstRepTyCon famInst
796                      in return (tycon', tys) }
797 \end{code}
798
799 Note [Looking up family instances for deriving]
800 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
801 tcLookupFamInstExact is an auxiliary lookup wrapper which requires
802 that looked-up family instances exist.  If called with a vanilla
803 tycon, the old type application is simply returned.
804
805 If we have
806   data instance F () = ... deriving Eq
807   data instance F () = ... deriving Eq
808 then tcLookupFamInstExact will be confused by the two matches;
809 but that can't happen because tcInstDecls1 doesn't call tcDeriving
810 if there are any overlaps.
811
812 There are two other things that might go wrong with the lookup.
813 First, we might see a standalone deriving clause
814    deriving Eq (F ())
815 when there is no data instance F () in scope.
816
817 Note that it's OK to have
818   data instance F [a] = ...
819   deriving Eq (F [(a,b)])
820 where the match is not exact; the same holds for ordinary data types
821 with standalone deriving declarations.
822
823 Note [Deriving, type families, and partial applications]
824 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
825 When there are no type families, it's quite easy:
826
827     newtype S a = MkS [a]
828     -- :CoS :: S  ~ []  -- Eta-reduced
829
830     instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
831     instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
832
833 When type familes are involved it's trickier:
834
835     data family T a b
836     newtype instance T Int a = MkT [a] deriving( Eq, Monad )
837     -- :RT is the representation type for (T Int a)
838     --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
839     --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!
840
841     instance Eq [a] => Eq (T Int a)     -- easy by coercion
842        -- d1 :: Eq [a]
843        -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
844
845     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
846        -- d1 :: Monad []
847        -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
848
849 Note the need for the eta-reduced rule axioms.  After all, we can
850 write it out
851     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
852       return x = MkT [x]
853       ... etc ...
854
855 See Note [Eta reduction for data family axioms] in TcInstDcls.
856
857
858 %************************************************************************
859 %*                                                                      *
860                 Deriving data types
861 %*                                                                      *
862 %************************************************************************
863
864 \begin{code}
865 mkDataTypeEqn :: CtOrigin
866               -> DynFlags
867               -> [Var]                  -- Universally quantified type variables in the instance
868               -> Class                  -- Class for which we need to derive an instance
869               -> [Type]                 -- Other parameters to the class except the last
870               -> TyCon                  -- Type constructor for which the instance is requested
871                                         --    (last parameter to the type class)
872               -> [Type]                 -- Parameters to the type constructor
873               -> TyCon                  -- rep of the above (for type families)
874               -> [Type]                 -- rep of the above
875               -> DerivContext        -- Context of the instance, for standalone deriving
876               -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error
877
878 mkDataTypeEqn orig dflags tvs cls cls_tys
879               tycon tc_args rep_tc rep_tc_args mtheta
880   = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
881         -- NB: pass the *representation* tycon to checkSideConditions
882         CanDerive               -> go_for_it
883         NonDerivableClass       -> bale_out (nonStdErr cls)
884         DerivableClassError msg -> bale_out msg
885   where
886     go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
887     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
888
889 mk_data_eqn :: CtOrigin -> [TyVar] -> Class
890             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
891             -> TcM EarlyDerivSpec
892 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
893   = do  { loc                  <- getSrcSpanM
894         ; dfun_name            <- new_dfun_name cls tycon
895         ; inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
896         ; let spec = DS { ds_loc = loc, ds_orig = orig
897                         , ds_name = dfun_name, ds_tvs = tvs
898                         , ds_cls = cls, ds_tys = inst_tys
899                         , ds_tc = rep_tc, ds_tc_args = rep_tc_args
900                         , ds_theta =  mtheta `orElse` inferred_constraints
901                         , ds_newtype = False }
902
903         ; return (if isJust mtheta then Right spec      -- Specified context
904                                    else Left spec) }    -- Infer context
905   where
906     inst_tys = [mkTyConApp tycon tc_args]
907
908 ----------------------
909 mkOldTypeableEqn :: CtOrigin -> [TyVar] -> Class
910                     -> TyCon -> [TcType] -> DerivContext
911                     -> TcM EarlyDerivSpec
912 -- The "old" (pre GHC 7.8 polykinded Typeable) deriving Typeable
913 -- used a horrid family of classes: Typeable, Typeable1, Typeable2, ... Typeable7
914 mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
915         -- The Typeable class is special in several ways
916         --        data T a b = ... deriving( Typeable )
917         -- gives
918         --        instance Typeable2 T where ...
919         -- Notice that:
920         -- 1. There are no constraints in the instance
921         -- 2. There are no type variables either
922         -- 3. The actual class we want to generate isn't necessarily
923         --      Typeable; it depends on the arity of the type
924   | isNothing mtheta    -- deriving on a data type decl
925   = do  { checkTc (cls `hasKey` oldTypeableClassKey)
926                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
927         ; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
928                       -- See Note [Getting base classes]
929         ; mkOldTypeableEqn orig tvs real_cls tycon [] (Just []) }
930
931   | otherwise           -- standalone deriving
932   = do  { checkTc (null tc_args)
933                   (ptext (sLit "Derived Typeable instance must be of form (Typeable")
934                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
935         ; dfun_name <- new_dfun_name cls tycon
936         ; loc <- getSrcSpanM
937         ; return (Right $
938                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
939                      , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
940                      , ds_tc = tycon, ds_tc_args = []
941                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
942
943 mkPolyKindedTypeableEqn :: CtOrigin -> [TyVar] -> Class
944                         -> TyCon -> [TcType] -> DerivContext
945                         -> TcM EarlyDerivSpec
946 -- We can arrive here from a 'deriving' clause
947 -- or from standalone deriving
948 mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta
949   = do  {    -- Check that we have not said, for example
950              --       deriving Typeable (T Int)
951              -- or    deriving Typeable (S :: * -> *)     where S is kind-polymorphic
952
953           polykinds <- xoptM Opt_PolyKinds
954         ; checkTc (all is_kind_var tc_args) (mk_msg polykinds)
955         ; dfun_name <- new_dfun_name cls tycon
956         ; loc <- getSrcSpanM
957         ; let tc_app = mkTyConApp tycon tc_args
958         ; return (Right $
959                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name
960                      , ds_tvs = filter isKindVar tvs, ds_cls = cls
961                      , ds_tys = typeKind tc_app : [tc_app]
962                          -- Remember, Typeable :: forall k. k -> *
963                      , ds_tc = tycon, ds_tc_args = tc_args
964                      , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
965                      , ds_newtype = False })  }
966   where
967     is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
968                            Just v  -> isKindVar v
969                            Nothing -> False
970
971     mk_msg polykinds | not polykinds
972                      , all isKind tc_args   -- Non-empty, all kinds, at least one not a kind variable
973                      = hang (ptext (sLit "To make a Typeable instance of poly-kinded")
974                               <+> quotes (ppr tycon) <> comma)
975                           2 (ptext (sLit "use XPolyKinds"))
976                      | otherwise
977                      = ptext (sLit "Derived Typeable instance must be of form")
978                        <+> parens (ptext (sLit "Typeable") <+> ppr tycon)
979
980
981 inferConstraints :: Class -> [TcType]
982                  -> TyCon -> [TcType]
983                  -> TcM ThetaType
984 -- Generate a sufficiently large set of constraints that typechecking the
985 -- generated method definitions should succeed.   This set will be simplified
986 -- before being used in the instance declaration
987 inferConstraints cls inst_tys rep_tc rep_tc_args
988   | cls `hasKey` genClassKey    -- Generic constraints are easy
989   = return []
990
991   | cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
992   = ASSERT(length rep_tc_tvs > 0)   -- See Note [Getting base classes]
993     do { functorClass <- tcLookupClass functorClassName
994        ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }
995
996   | otherwise  -- The others are a bit more complicated
997   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
998     return (stupid_constraints ++ extra_constraints
999             ++ sc_constraints
1000             ++ con_arg_constraints cls get_std_constrained_tys)
1001
1002   where
1003        -- Constraints arising from the arguments of each constructor
1004     con_arg_constraints cls' get_constrained_tys
1005       = [ mkClassPred cls' [arg_ty]
1006         | data_con <- tyConDataCons rep_tc,
1007           arg_ty   <- ASSERT( isVanillaDataCon data_con )
1008                         get_constrained_tys $
1009                         dataConInstOrigArgTys data_con all_rep_tc_args,
1010           not (isUnLiftedType arg_ty) ]
1011                 -- No constraints for unlifted types
1012                 -- See Note [Deriving and unboxed types]
1013
1014                 -- For functor-like classes, two things are different
1015                 -- (a) We recurse over argument types to generate constraints
1016                 --     See Functor examples in TcGenDeriv
1017                 -- (b) The rep_tc_args will be one short
1018     is_functor_like = getUnique cls `elem` functorLikeClassKeys
1019
1020     get_std_constrained_tys :: [Type] -> [Type]
1021     get_std_constrained_tys tys
1022         | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
1023         | otherwise       = tys
1024
1025     rep_tc_tvs = tyConTyVars rep_tc
1026     last_tv = last rep_tc_tvs
1027     all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
1028                       = rep_tc_args ++ [mkTyVarTy last_tv]
1029                     | otherwise       = rep_tc_args
1030
1031         -- Constraints arising from superclasses
1032         -- See Note [Superclasses of derived instance]
1033     sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
1034                                 (classSCTheta cls)
1035
1036         -- Stupid constraints
1037     stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
1038     subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
1039
1040         -- Extra Data constraints
1041         -- The Data class (only) requires that for
1042         --    instance (...) => Data (T t1 t2)
1043         -- IF   t1:*, t2:*
1044         -- THEN (Data t1, Data t2) are among the (...) constraints
1045         -- Reason: when the IF holds, we generate a method
1046         --             dataCast2 f = gcast2 f
1047         --         and we need the Data constraints to typecheck the method
1048     extra_constraints
1049       | cls `hasKey` dataClassKey
1050       , all (isLiftedTypeKind . typeKind) rep_tc_args
1051       = [mkClassPred cls [ty] | ty <- rep_tc_args]
1052       | otherwise
1053       = []
1054 \end{code}
1055
1056 Note [Getting base classes]
1057 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1058 Functor and Typeable are defined in package 'base', and that is not available
1059 when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
1060 ghc-prim does not use Functor or Typeable implicitly via these lookups.
1061
1062 Note [Deriving and unboxed types]
1063 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1064 We have some special hacks to support things like
1065    data T = MkT Int# deriving ( Show )
1066
1067 Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
1068 (which we know how to show). It's a bit ad hoc.
1069
1070
1071 \begin{code}
1072 ------------------------------------------------------------------
1073 -- Check side conditions that dis-allow derivability for particular classes
1074 -- This is *apart* from the newtype-deriving mechanism
1075 --
1076 -- Here we get the representation tycon in case of family instances as it has
1077 -- the data constructors - but we need to be careful to fall back to the
1078 -- family tycon (with indexes) in error messages.
1079
1080 data DerivStatus = CanDerive
1081                  | DerivableClassError SDoc  -- Standard class, but can't do it
1082                  | NonDerivableClass         -- Non-standard class
1083
1084 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
1085                     -> TyCon -> [Type] -- tycon and its parameters
1086                     -> DerivStatus
1087 checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
1088   | Just cond <- sideConditions mtheta cls
1089   = case (cond (dflags, rep_tc, rep_tc_args)) of
1090         Just err -> DerivableClassError err     -- Class-specific error
1091         Nothing  | null cls_tys -> CanDerive    -- All derivable classes are unary, so
1092                                                 -- cls_tys (the type args other than last)
1093                                                 -- should be null
1094                  | otherwise    -> DerivableClassError (classArgsErr cls cls_tys)  -- e.g. deriving( Eq s )
1095   | otherwise = NonDerivableClass       -- Not a standard class
1096
1097 classArgsErr :: Class -> [Type] -> SDoc
1098 classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
1099
1100 checkTypeableConditions, checkOldTypeableConditions :: Condition
1101 checkTypeableConditions    = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK
1102 checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
1103
1104 nonStdErr :: Class -> SDoc
1105 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
1106
1107 sideConditions :: DerivContext -> Class -> Maybe Condition
1108 sideConditions mtheta cls
1109   | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
1110   | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
1111   | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
1112   | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
1113   | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
1114   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
1115   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
1116   | cls_key == dataClassKey        = Just (checkFlag Opt_DeriveDataTypeable `andCond`
1117                                            cond_std `andCond` cond_args cls)
1118   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
1119                                            cond_functorOK True)  -- NB: no cond_std!
1120   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
1121                                            cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
1122   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
1123                                            cond_functorOK False)
1124   | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
1125                                            checkFlag Opt_DeriveGeneric)
1126   | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
1127                                            checkFlag Opt_DeriveGeneric)
1128   | otherwise = Nothing
1129   where
1130     cls_key = getUnique cls
1131     cond_std = cond_stdOK mtheta
1132
1133 type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc
1134         -- first Bool is whether or not we are allowed to derive Data and Typeable
1135         -- second Bool is whether or not we are allowed to derive Functor
1136         -- TyCon is the *representation* tycon if the data type is an indexed one
1137         -- [Type] are the type arguments to the (representation) TyCon
1138         -- Nothing => OK
1139
1140 orCond :: Condition -> Condition -> Condition
1141 orCond c1 c2 tc
1142   = case c1 tc of
1143         Nothing -> Nothing          -- c1 succeeds
1144         Just x  -> case c2 tc of    -- c1 fails
1145                      Nothing -> Nothing
1146                      Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
1147                                     -- Both fail
1148
1149 andCond :: Condition -> Condition -> Condition
1150 andCond c1 c2 tc = case c1 tc of
1151                      Nothing -> c2 tc   -- c1 succeeds
1152                      Just x  -> Just x  -- c1 fails
1153
1154 cond_stdOK :: DerivContext -> Condition
1155 cond_stdOK (Just _) _
1156   = Nothing     -- Don't check these conservative conditions for
1157                 -- standalone deriving; just generate the code
1158                 -- and let the typechecker handle the result
1159 cond_stdOK Nothing (_, rep_tc, _)
1160   | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
1161   | not (null con_whys) = Just (vcat con_whys $$ suggestion)
1162   | otherwise           = Nothing
1163   where
1164     suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
1165     data_cons   = tyConDataCons rep_tc
1166     con_whys = mapCatMaybes check_con data_cons
1167
1168     check_con :: DataCon -> Maybe SDoc
1169     check_con con
1170       | isVanillaDataCon con
1171       , all isTauTy (dataConOrigArgTys con) = Nothing
1172       | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
1173
1174 no_cons_why :: TyCon -> SDoc
1175 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
1176                      ptext (sLit "must have at least one data constructor")
1177
1178 cond_RepresentableOk :: Condition
1179 cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args
1180
1181 cond_Representable1Ok :: Condition
1182 cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args
1183
1184 cond_enumOrProduct :: Class -> Condition
1185 cond_enumOrProduct cls = cond_isEnumeration `orCond`
1186                          (cond_isProduct `andCond` cond_args cls)
1187
1188 cond_args :: Class -> Condition
1189 -- For some classes (eg Eq, Ord) we allow unlifted arg types
1190 -- by generating specilaised code.  For others (eg Data) we don't.
1191 cond_args cls (_, tc, _)
1192   = case bad_args of
1193       []      -> Nothing
1194       (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
1195                          2 (ptext (sLit "for type") <+> quotes (ppr ty)))
1196   where
1197     bad_args = [ arg_ty | con <- tyConDataCons tc
1198                         , arg_ty <- dataConOrigArgTys con
1199                         , isUnLiftedType arg_ty
1200                         , not (ok_ty arg_ty) ]
1201
1202     cls_key = classKey cls
1203     ok_ty arg_ty
1204      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
1205      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
1206      | cls_key == showClassKey = check_in arg_ty boxConTbl
1207      | otherwise               = False    -- Read, Ix etc
1208
1209     check_in :: Type -> [(Type,a)] -> Bool
1210     check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
1211
1212
1213 cond_isEnumeration :: Condition
1214 cond_isEnumeration (_, rep_tc, _)
1215   | isEnumerationTyCon rep_tc = Nothing
1216   | otherwise                 = Just why
1217   where
1218     why = sep [ quotes (pprSourceTyCon rep_tc) <+>
1219                   ptext (sLit "must be an enumeration type")
1220               , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
1221                   -- See Note [Enumeration types] in TyCon
1222
1223 cond_isProduct :: Condition
1224 cond_isProduct (_, rep_tc, _)
1225   | isProductTyCon rep_tc = Nothing
1226   | otherwise             = Just why
1227   where
1228     why = quotes (pprSourceTyCon rep_tc) <+>
1229           ptext (sLit "must have precisely one constructor")
1230
1231 cond_oldTypeableOK :: Condition
1232 -- OK for kind-monomorphic Typeable class
1233 -- Currently: (a) args all of kind *
1234 --            (b) 7 or fewer args
1235 cond_oldTypeableOK (_, tc, _)
1236   | tyConArity tc > 7 = Just too_many
1237   | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
1238                       = Just bad_kind
1239   | otherwise         = Nothing
1240   where
1241     too_many = quotes (pprSourceTyCon tc) <+>
1242                ptext (sLit "must have 7 or fewer arguments")
1243     bad_kind = quotes (pprSourceTyCon tc) <+>
1244                ptext (sLit "must only have arguments of kind `*'")
1245
1246 cond_TypeableOK :: Condition
1247 -- Only not ok if it's a data instance
1248 cond_TypeableOK (_, tc, tc_args)
1249   | isDataFamilyTyCon tc && not (null tc_args)
1250   = Just no_families
1251
1252   | otherwise
1253   = Nothing
1254   where
1255     no_families = sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;")
1256                       , ptext (sLit "derive Typeable for")
1257                           <+> quotes (pprSourceTyCon tc)
1258                           <+> ptext (sLit "alone") ]
1259
1260 functorLikeClassKeys :: [Unique]
1261 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
1262
1263 cond_functorOK :: Bool -> Condition
1264 -- OK for Functor/Foldable/Traversable class
1265 -- Currently: (a) at least one argument
1266 --            (b) don't use argument contravariantly
1267 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
1268 --            (d) optionally: don't use function types
1269 --            (e) no "stupid context" on data type
1270 cond_functorOK allowFunctions (_, rep_tc, _)
1271   | null tc_tvs
1272   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1273           <+> ptext (sLit "must have some type parameters"))
1274
1275   | not (null bad_stupid_theta)
1276   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
1277           <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
1278
1279   | otherwise
1280   = msum (map check_con data_cons)      -- msum picks the first 'Just', if any
1281   where
1282     tc_tvs            = tyConTyVars rep_tc
1283     Just (_, last_tv) = snocView tc_tvs
1284     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
1285     is_bad pred       = last_tv `elemVarSet` tyVarsOfType pred
1286
1287     data_cons = tyConDataCons rep_tc
1288     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
1289
1290     check_vanilla :: DataCon -> Maybe SDoc
1291     check_vanilla con | isVanillaDataCon con = Nothing
1292                       | otherwise            = Just (badCon con existential)
1293
1294     ft_check :: DataCon -> FFoldType (Maybe SDoc)
1295     ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
1296                       , ft_co_var = Just (badCon con covariant)
1297                       , ft_fun = \x y -> if allowFunctions then x `mplus` y
1298                                                            else Just (badCon con functions)
1299                       , ft_tup = \_ xs  -> msum xs
1300                       , ft_ty_app = \_ x   -> x
1301                       , ft_bad_app = Just (badCon con wrong_arg)
1302                       , ft_forall = \_ x   -> x }
1303
1304     existential = ptext (sLit "must not have existential arguments")
1305     covariant   = ptext (sLit "must not use the type variable in a function argument")
1306     functions   = ptext (sLit "must not contain function types")
1307     wrong_arg   = ptext (sLit "must use the type variable only as the last argument of a data type")
1308
1309 allDistinctTyVars :: [KindOrType] -> Bool
1310 allDistinctTyVars tkvs = go emptyVarSet tkvs
1311   where
1312     go _      [] = True
1313     go so_far (ty : tys)
1314        = case getTyVar_maybe ty of
1315              Nothing -> False
1316              Just tv | tv `elemVarSet` so_far -> False
1317                      | otherwise -> go (so_far `extendVarSet` tv) tys
1318
1319 checkFlag :: ExtensionFlag -> Condition
1320 checkFlag flag (dflags, _, _)
1321   | xopt flag dflags = Nothing
1322   | otherwise        = Just why
1323   where
1324     why = ptext (sLit "You need ") <> text flag_str
1325           <+> ptext (sLit "to derive an instance for this class")
1326     flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
1327                  [s]   -> s
1328                  other -> pprPanic "checkFlag" (ppr other)
1329
1330 std_class_via_coercible :: Class -> Bool
1331 -- These standard classes can be derived for a newtype
1332 -- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
1333 -- because giving so gives the same results as generating the boilerplate
1334 std_class_via_coercible clas
1335   = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
1336         -- Not Read/Show because they respect the type
1337         -- Not Enum, because newtypes are never in Enum
1338
1339
1340 non_coercible_class :: Class -> Bool
1341 -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by Coercible,
1342 -- even with -XGeneralizedNewtypeDeriving
1343 -- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
1344 -- instance behave differently if there's a non-lawful Applicative out there.
1345 -- Besides, with roles, Coercible-deriving Traversable is ill-roled.
1346 non_coercible_class cls
1347   = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
1348                          , genClassKey, gen1ClassKey, typeableClassKey
1349                          , traversableClassKey ]
1350                          ++ oldTypeableClassKeys)
1351
1352 oldTypeableClassKeys :: [Unique]
1353 oldTypeableClassKeys = map getUnique oldTypeableClassNames
1354
1355 new_dfun_name :: Class -> TyCon -> TcM Name
1356 new_dfun_name clas tycon        -- Just a simple wrapper
1357   = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
1358         ; newDFunName clas [mkTyConApp tycon []] loc }
1359         -- The type passed to newDFunName is only used to generate
1360         -- a suitable string; hence the empty type arg list
1361
1362 badCon :: DataCon -> SDoc -> SDoc
1363 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1364 \end{code}
1365
1366 Note [Superclasses of derived instance]
1367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1368 In general, a derived instance decl needs the superclasses of the derived
1369 class too.  So if we have
1370         data T a = ...deriving( Ord )
1371 then the initial context for Ord (T a) should include Eq (T a).  Often this is
1372 redundant; we'll also generate an Ord constraint for each constructor argument,
1373 and that will probably generate enough constraints to make the Eq (T a) constraint
1374 be satisfied too.  But not always; consider:
1375
1376  data S a = S
1377  instance Eq (S a)
1378  instance Ord (S a)
1379
1380  data T a = MkT (S a) deriving( Ord )
1381  instance Num a => Eq (T a)
1382
1383 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1384 Similarly consider:
1385         data T a = MkT deriving( Data, Typeable )
1386 Here there *is* no argument field, but we must nevertheless generate
1387 a context for the Data instances:
1388         instance Typable a => Data (T a) where ...
1389
1390
1391 %************************************************************************
1392 %*                                                                      *
1393                 Deriving newtypes
1394 %*                                                                      *
1395 %************************************************************************
1396
1397 \begin{code}
1398 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1399              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1400              -> DerivContext
1401              -> TcRn EarlyDerivSpec
1402 mkNewTypeEqn orig dflags tvs
1403              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1404 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1405   | might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls)
1406   = do  { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1407         ; dfun_name <- new_dfun_name cls tycon
1408         ; loc <- getSrcSpanM
1409         ; let spec = DS { ds_loc = loc, ds_orig = orig
1410                         , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
1411                         , ds_cls = cls, ds_tys = inst_tys
1412                         , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1413                         , ds_theta =  mtheta `orElse` all_preds
1414                         , ds_newtype = True }
1415         ; return (if isJust mtheta then Right spec
1416                                    else Left spec) }
1417
1418   | otherwise
1419   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
1420       CanDerive -> go_for_it    -- Use the standard H98 method
1421       DerivableClassError msg   -- Error with standard class
1422         | might_derive_via_coercible -> bale_out (msg $$ suggest_nd)
1423         | otherwise                  -> bale_out msg
1424       NonDerivableClass         -- Must use newtype deriving
1425         | newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
1426         | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1427         | otherwise                  -> bale_out non_std
1428   where
1429         newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1430         go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1431         bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1432
1433         non_std    = nonStdErr cls
1434         suggest_nd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1435
1436         -- Here is the plan for newtype derivings.  We see
1437         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1438         -- where t is a type,
1439         --       ak+1...an is a suffix of a1..an, and are all tyars
1440         --       ak+1...an do not occur free in t, nor in the s1..sm
1441         --       (C s1 ... sm) is a  *partial applications* of class C
1442         --                      with the last parameter missing
1443         --       (T a1 .. ak) matches the kind of C's last argument
1444         --              (and hence so does t)
1445         -- The latter kind-check has been done by deriveTyData already,
1446         -- and tc_args are already trimmed
1447         --
1448         -- We generate the instance
1449         --       instance forall ({a1..ak} u fvs(s1..sm)).
1450         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
1451         -- where T a1...ap is the partial application of
1452         --       the LHS of the correct kind and p >= k
1453         --
1454         --      NB: the variables below are:
1455         --              tc_tvs = [a1, ..., an]
1456         --              tyvars_to_keep = [a1, ..., ak]
1457         --              rep_ty = t ak .. an
1458         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
1459         --              tys = [s1, ..., sm]
1460         --              rep_fn' = t
1461         --
1462         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1463         -- We generate the instance
1464         --      instance Monad (ST s) => Monad (T s) where
1465
1466         nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1467                 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1468                 -- eta-reduces the representation type, so we know that
1469                 --      T a ~ S a a
1470                 -- That's convenient here, because we may have to apply
1471                 -- it to fewer than its original complement of arguments
1472
1473         -- Note [Newtype representation]
1474         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1475         -- Need newTyConRhs (*not* a recursive representation finder)
1476         -- to get the representation type. For example
1477         --      newtype B = MkB Int
1478         --      newtype A = MkA B deriving( Num )
1479         -- We want the Num instance of B, *not* the Num instance of Int,
1480         -- when making the Num instance of A!
1481         rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1482         rep_tys     = cls_tys ++ [rep_inst_ty]
1483         rep_pred    = mkClassPred cls rep_tys
1484                 -- rep_pred is the representation dictionary, from where
1485                 -- we are gong to get all the methods for the newtype
1486                 -- dictionary
1487
1488
1489     -- Next we figure out what superclass dictionaries to use
1490     -- See Note [Newtype deriving superclasses] above
1491
1492         cls_tyvars = classTyVars cls
1493         dfun_tvs = tyVarsOfTypes inst_tys
1494         inst_ty = mkTyConApp tycon tc_args
1495         inst_tys = cls_tys ++ [inst_ty]
1496         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1497                               (classSCTheta cls)
1498
1499                 -- If there are no tyvars, there's no need
1500                 -- to abstract over the dictionaries we need
1501                 -- Example:     newtype T = MkT Int deriving( C )
1502                 -- We get the derived instance
1503                 --              instance C T
1504                 -- rather than
1505                 --              instance C Int => C T
1506         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
1507
1508         -------------------------------------------------------------------
1509         --  Figuring out whether we can only do this newtype-deriving thing
1510
1511         -- See Note [Determining whether newtype-deriving is appropriate]
1512         might_derive_via_coercible
1513            =  not (non_coercible_class cls)
1514            && arity_ok
1515            && eta_ok
1516            && ats_ok
1517 --         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
1518
1519         arity_ok = length cls_tys + 1 == classArity cls
1520                 -- Well kinded; eg not: newtype T ... deriving( ST )
1521                 --                      because ST needs *2* type params
1522
1523         -- Check that eta reduction is OK
1524         eta_ok = nt_eta_arity <= length rep_tc_args
1525                 -- The newtype can be eta-reduced to match the number
1526                 --     of type argument actually supplied
1527                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
1528                 --     Here the 'b' must be the same in the rep type (S [a] b)
1529                 --     And the [a] must not mention 'b'.  That's all handled
1530                 --     by nt_eta_rity.
1531
1532         ats_ok = null (classATs cls)
1533                -- No associated types for the class, because we don't
1534                -- currently generate type 'instance' decls; and cannot do
1535                -- so for 'data' instance decls
1536
1537         cant_derive_err
1538            = vcat [ ppUnless arity_ok arity_msg
1539                   , ppUnless eta_ok eta_msg
1540                   , ppUnless ats_ok ats_msg ]
1541         arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1542         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
1543         ats_msg   = ptext (sLit "the class has associated types")
1544
1545 \end{code}
1546
1547 Note [Recursive newtypes]
1548 ~~~~~~~~~~~~~~~~~~~~~~~~~
1549 Newtype deriving works fine, even if the newtype is recursive.
1550 e.g.    newtype S1 = S1 [T1 ()]
1551         newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1552 Remember, too, that type families are curretly (conservatively) given
1553 a recursive flag, so this also allows newtype deriving to work
1554 for type famillies.
1555
1556 We used to exclude recursive types, because we had a rather simple
1557 minded way of generating the instance decl:
1558    newtype A = MkA [A]
1559    instance Eq [A] => Eq A      -- Makes typechecker loop!
1560 But now we require a simple context, so it's ok.
1561
1562 Note [Role checking in GND]
1563 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1564 When checking to see if GND (GeneralizedNewtypeDeriving) is possible, we
1565 do *not* look at the roles of the class being derived. Instead, we look
1566 at the uses of the last type variable to that class in all the methods of
1567 the class. (Why? Keep reading.) For example:
1568
1569   class Foo a b where
1570     meth :: a b -> b
1571
1572   instance Foo Maybe Int where
1573     meth = fromJust
1574
1575   newtype Age = MkAge Int
1576     deriving (Foo Maybe)
1577
1578 According to the role rules, the `b` parameter to Foo must be at nominal
1579 role -- after all, `a` could be a GADT. BUT, when deriving (Foo Maybe)
1580 for Age, we in fact know that `a` is *not* a GADT. So, instead of looking
1581 holistically at the roles for the parameters of Foo, we instead perform
1582 the substitution on the type variables that we know (in this case,
1583 [a |-> Maybe]) and then check each method individually.
1584
1585 Why check only methods, and not other things? In GND, superclass constraints
1586 must be satisfied by the *newtype*, not the *base type*. So, we don't coerce
1587 the base type's superclass dictionaries in GND, and we don't need to check
1588 them here. For associated types, GND is impossible anyway, so we don't need
1589 to look. All that is left is methods.
1590
1591 Note [Determining whether newtype-deriving is appropriate]
1592 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1593 When we see
1594   newtype NT = MkNT Foo
1595     deriving C
1596 we have to decide how to perform the deriving. Do we do newtype deriving,
1597 or do we do normal deriving? In general, we prefer to do newtype deriving
1598 wherever possible. So, we try newtype deriving unless there's a glaring
1599 reason not to.
1600
1601 Note that newtype deriving might fail, even after we commit to it. This
1602 is because the derived instance uses `coerce`, which must satisfy its
1603 `Coercible` constraint. This is different than other deriving scenarios,
1604 where we're sure that the resulting instance will type-check.
1605
1606 %************************************************************************
1607 %*                                                                      *
1608 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1609 %*                                                                      *
1610 %************************************************************************
1611
1612 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1613 terms, which is the final correct RHS for the corresponding original
1614 equation.
1615 \begin{itemize}
1616 \item
1617 Each (k,TyVarTy tv) in a solution constrains only a type
1618 variable, tv.
1619
1620 \item
1621 The (k,TyVarTy tv) pairs in a solution are canonically
1622 ordered by sorting on type varible, tv, (major key) and then class, k,
1623 (minor key)
1624 \end{itemize}
1625
1626 \begin{code}
1627 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1628
1629 inferInstanceContexts _ [] = return []
1630
1631 inferInstanceContexts oflag infer_specs
1632   = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1633         ; iterate_deriv 1 initial_solutions }
1634   where
1635     ------------------------------------------------------------------
1636         -- The initial solutions for the equations claim that each
1637         -- instance has an empty context; this solution is certainly
1638         -- in canonical form.
1639     initial_solutions :: [ThetaType]
1640     initial_solutions = [ [] | _ <- infer_specs ]
1641
1642     ------------------------------------------------------------------
1643         -- iterate_deriv calculates the next batch of solutions,
1644         -- compares it with the current one; finishes if they are the
1645         -- same, otherwise recurses with the new solutions.
1646         -- It fails if any iteration fails
1647     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1648     iterate_deriv n current_solns
1649       | n > 20  -- Looks as if we are in an infinite loop
1650                 -- This can happen if we have -XUndecidableInstances
1651                 -- (See TcSimplify.tcSimplifyDeriv.)
1652       = pprPanic "solveDerivEqns: probable loop"
1653                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1654       | otherwise
1655       = do {      -- Extend the inst info from the explicit instance decls
1656                   -- with the current set of solutions, and simplify each RHS
1657              inst_specs <- zipWithM (mkInstance oflag) current_solns infer_specs
1658            ; new_solns <- checkNoErrs $
1659                           extendLocalInstEnv inst_specs $
1660                           mapM gen_soln infer_specs
1661
1662            ; let eqList :: (a -> b -> Bool) -> [a] -> [b] -> Bool
1663                  eqList f xs ys = length xs == length ys && and (zipWith f xs ys)
1664
1665            ; if (eqList (eqList eqType) current_solns new_solns) then
1666                 return [ spec { ds_theta = soln }
1667                        | (spec, soln) <- zip infer_specs current_solns ]
1668              else
1669                 iterate_deriv (n+1) new_solns }
1670
1671     ------------------------------------------------------------------
1672     gen_soln :: DerivSpec  -> TcM [PredType]
1673     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1674                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1675       = setSrcSpan loc  $
1676         addErrCtxt (derivInstCtxt the_pred) $
1677         do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
1678                 -- checkValidInstance tyvars theta clas inst_tys
1679                 -- Not necessary; see Note [Exotic derived instance contexts]
1680                 --                in TcSimplify
1681
1682            ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1683                 -- Claim: the result instance declaration is guaranteed valid
1684                 -- Hence no need to call:
1685                 --   checkValidInstance tyvars theta clas inst_tys
1686            ; return (sortBy cmpType theta) }    -- Canonicalise before returning the solution
1687       where
1688         the_pred = mkClassPred clas inst_tys
1689
1690 ------------------------------------------------------------------
1691 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> TcM ClsInst
1692 mkInstance overlap_flag theta
1693            (DS { ds_name = dfun_name
1694                , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
1695   = do { (subst, tvs') <- tcInstSkolTyVars tvs
1696        ; return (mkLocalInstance dfun overlap_flag tvs' clas (substTys subst tys)) }
1697   where
1698     dfun = mkDictFunId dfun_name tvs theta clas tys
1699
1700
1701 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
1702 -- Add new locally-defined instances; don't bother to check
1703 -- for functional dependency errors -- that'll happen in TcInstDcls
1704 extendLocalInstEnv dfuns thing_inside
1705  = do { env <- getGblEnv
1706       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1707              env'      = env { tcg_inst_env = inst_env' }
1708       ; setGblEnv env' thing_inside }
1709 \end{code}
1710
1711
1712 ***********************************************************************************
1713 *                                                                                 *
1714 *            Simplify derived constraints
1715 *                                                                                 *
1716 ***********************************************************************************
1717
1718 \begin{code}
1719 simplifyDeriv :: CtOrigin
1720               -> PredType
1721               -> [TyVar]
1722               -> ThetaType              -- Wanted
1723               -> TcM ThetaType  -- Needed
1724 -- Given  instance (wanted) => C inst_ty
1725 -- Simplify 'wanted' as much as possibles
1726 -- Fail if not possible
1727 simplifyDeriv orig pred tvs theta
1728   = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
1729                 -- The constraint solving machinery
1730                 -- expects *TcTyVars* not TyVars.
1731                 -- We use *non-overlappable* (vanilla) skolems
1732                 -- See Note [Overlap and deriving]
1733
1734        ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
1735              skol_set   = mkVarSet tvs_skols
1736              doc = ptext (sLit "deriving") <+> parens (ppr pred)
1737
1738        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
1739
1740        ; traceTc "simplifyDeriv" $
1741          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
1742        ; (residual_wanted, _ev_binds1)
1743              <- solveWantedsTcM (mkFlatWC wanted)
1744                 -- Post: residual_wanted are already zonked
1745
1746        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
1747                          -- See Note [Exotic derived instance contexts]
1748              get_good :: Ct -> Either PredType Ct
1749              get_good ct | validDerivPred skol_set p
1750                          , isWantedCt ct  = Left p
1751                          -- NB: residual_wanted may contain unsolved
1752                          -- Derived and we stick them into the bad set
1753                          -- so that reportUnsolved may decide what to do with them
1754                          | otherwise = Right ct
1755                          where p = ctPred ct
1756
1757        -- We never want to defer these errors because they are errors in the
1758        -- compiler! Hence the `False` below
1759        ; reportAllUnsolved (residual_wanted { wc_flat = bad })
1760
1761        ; let min_theta = mkMinimalBySCs (bagToList good)
1762        ; return (substTheta subst_skol min_theta) }
1763 \end{code}
1764
1765 Note [Overlap and deriving]
1766 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1767 Consider some overlapping instances:
1768   data Show a => Show [a] where ..
1769   data Show [Char] where ...
1770
1771 Now a data type with deriving:
1772   data T a = MkT [a] deriving( Show )
1773
1774 We want to get the derived instance
1775   instance Show [a] => Show (T a) where...
1776 and NOT
1777   instance Show a => Show (T a) where...
1778 so that the (Show (T Char)) instance does the Right Thing
1779
1780 It's very like the situation when we're inferring the type
1781 of a function
1782    f x = show [x]
1783 and we want to infer
1784    f :: Show [a] => a -> String
1785
1786 BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
1787              the context for the derived instance.
1788              Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
1789
1790 Note [Exotic derived instance contexts]
1791 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1792 In a 'derived' instance declaration, we *infer* the context.  It's a
1793 bit unclear what rules we should apply for this; the Haskell report is
1794 silent.  Obviously, constraints like (Eq a) are fine, but what about
1795         data T f a = MkT (f a) deriving( Eq )
1796 where we'd get an Eq (f a) constraint.  That's probably fine too.
1797
1798 One could go further: consider
1799         data T a b c = MkT (Foo a b c) deriving( Eq )
1800         instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
1801
1802 Notice that this instance (just) satisfies the Paterson termination
1803 conditions.  Then we *could* derive an instance decl like this:
1804
1805         instance (C Int a, Eq b, Eq c) => Eq (T a b c)
1806 even though there is no instance for (C Int a), because there just
1807 *might* be an instance for, say, (C Int Bool) at a site where we
1808 need the equality instance for T's.
1809
1810 However, this seems pretty exotic, and it's quite tricky to allow
1811 this, and yet give sensible error messages in the (much more common)
1812 case where we really want that instance decl for C.
1813
1814 So for now we simply require that the derived instance context
1815 should have only type-variable constraints.
1816
1817 Here is another example:
1818         data Fix f = In (f (Fix f)) deriving( Eq )
1819 Here, if we are prepared to allow -XUndecidableInstances we
1820 could derive the instance
1821         instance Eq (f (Fix f)) => Eq (Fix f)
1822 but this is so delicate that I don't think it should happen inside
1823 'deriving'. If you want this, write it yourself!
1824
1825 NB: if you want to lift this condition, make sure you still meet the
1826 termination conditions!  If not, the deriving mechanism generates
1827 larger and larger constraints.  Example:
1828   data Succ a = S a
1829   data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
1830
1831 Note the lack of a Show instance for Succ.  First we'll generate
1832   instance (Show (Succ a), Show a) => Show (Seq a)
1833 and then
1834   instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
1835 and so on.  Instead we want to complain of no instance for (Show (Succ a)).
1836
1837 The bottom line
1838 ~~~~~~~~~~~~~~~
1839 Allow constraints which consist only of type variables, with no repeats.
1840
1841
1842 %************************************************************************
1843 %*                                                                      *
1844 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1845 %*                                                                      *
1846 %************************************************************************
1847
1848 After all the trouble to figure out the required context for the
1849 derived instance declarations, all that's left is to chug along to
1850 produce them.  They will then be shoved into @tcInstDecls2@, which
1851 will do all its usual business.
1852
1853 There are lots of possibilities for code to generate.  Here are
1854 various general remarks.
1855
1856 PRINCIPLES:
1857 \begin{itemize}
1858 \item
1859 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1860 ``you-couldn't-do-better-by-hand'' efficient.
1861
1862 \item
1863 Deriving @Show@---also pretty common--- should also be reasonable good code.
1864
1865 \item
1866 Deriving for the other classes isn't that common or that big a deal.
1867 \end{itemize}
1868
1869 PRAGMATICS:
1870
1871 \begin{itemize}
1872 \item
1873 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1874
1875 \item
1876 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1877
1878 \item
1879 We {\em normally} generate code only for the non-defaulted methods;
1880 there are some exceptions for @Eq@ and (especially) @Ord@...
1881
1882 \item
1883 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1884 constructor's numeric (@Int#@) tag.  These are generated by
1885 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1886 these is around is given by @hasCon2TagFun@.
1887
1888 The examples under the different sections below will make this
1889 clearer.
1890
1891 \item
1892 Much less often (really just for deriving @Ix@), we use a
1893 @_tag2con_<tycon>@ function.  See the examples.
1894
1895 \item
1896 We use the renamer!!!  Reason: we're supposed to be
1897 producing @LHsBinds Name@ for the methods, but that means
1898 producing correctly-uniquified code on the fly.  This is entirely
1899 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1900 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1901 the renamer.  What a great hack!
1902 \end{itemize}
1903
1904 \begin{code}
1905 -- Generate the InstInfo for the required instance paired with the
1906 --   *representation* tycon for that instance,
1907 -- plus any auxiliary bindings required
1908 --
1909 -- Representation tycons differ from the tycon in the instance signature in
1910 -- case of instances for indexed families.
1911 --
1912 genInst :: Bool             -- True <=> standalone deriving
1913         -> OverlapFlag
1914         -> CommonAuxiliaries
1915         -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
1916 genInst standalone_deriv oflag comauxs
1917         spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1918                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
1919                  , ds_name = name, ds_cls = clas, ds_loc = loc })
1920   | is_newtype
1921   = do { inst_spec <- mkInstance oflag theta spec
1922        ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty])
1923        ; return ( InstInfo
1924                     { iSpec   = inst_spec
1925                     , iBinds  = InstBindings
1926                         { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
1927                         , ib_pragmas = []
1928                         , ib_standalone_deriving = standalone_deriv } }
1929                 , emptyBag
1930                 , Just $ getName $ head $ tyConDataCons rep_tycon ) }
1931               -- See Note [Newtype deriving and unused constructors]
1932
1933   | otherwise
1934   = do { fix_env <- getFixityEnv
1935        ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
1936                                         fix_env clas name rep_tycon
1937                                         (lookup rep_tycon comauxs)
1938        ; inst_spec <- mkInstance oflag theta spec
1939        ; let inst_info = InstInfo { iSpec   = inst_spec
1940                                   , iBinds  = InstBindings
1941                                                 { ib_binds = meth_binds
1942                                                 , ib_pragmas = []
1943                                                 , ib_standalone_deriving = standalone_deriv } }
1944        ; return ( inst_info, deriv_stuff, Nothing ) }
1945   where
1946     rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
1947
1948 genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
1949               -> Maybe CommonAuxiliary
1950               -> TcM (LHsBinds RdrName, BagDerivStuff)
1951 genDerivStuff loc fix_env clas name tycon comaux_maybe
1952   | className clas `elem` oldTypeableClassNames
1953   = do dflags <- getDynFlags
1954        return (gen_old_Typeable_binds dflags loc tycon, emptyBag)
1955
1956   | className clas == typeableClassName
1957   = do dflags <- getDynFlags
1958        return (gen_Typeable_binds dflags loc tycon, emptyBag)
1959
1960   | ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
1961   = let gk =  if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One
1962         Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
1963     in do
1964       (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name)
1965       return (binds, DerivFamInst faminst `consBag` emptyBag)
1966
1967   | otherwise                      -- Non-monadic generators
1968   = do dflags <- getDynFlags
1969        case assocMaybe (gen_list dflags) (getUnique clas) of
1970         Just gen_fn -> return (gen_fn loc tycon)
1971         Nothing     -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
1972   where
1973     ck = classKey clas
1974
1975     gen_list :: DynFlags
1976              -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
1977     gen_list dflags
1978              = [(eqClassKey, gen_Eq_binds)
1979                ,(ordClassKey, gen_Ord_binds)
1980                ,(enumClassKey, gen_Enum_binds)
1981                ,(boundedClassKey, gen_Bounded_binds)
1982                ,(ixClassKey, gen_Ix_binds)
1983                ,(showClassKey, gen_Show_binds fix_env)
1984                ,(readClassKey, gen_Read_binds fix_env)
1985                ,(dataClassKey, gen_Data_binds dflags)
1986                ,(functorClassKey, gen_Functor_binds)
1987                ,(foldableClassKey, gen_Foldable_binds)
1988                ,(traversableClassKey, gen_Traversable_binds)
1989                ]
1990 \end{code}
1991
1992 %************************************************************************
1993 %*                                                                      *
1994 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1995 %*                                                                      *
1996 %************************************************************************
1997
1998 \begin{code}
1999 derivingNullaryErr :: MsgDoc
2000 derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes")
2001
2002 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc
2003 derivingKindErr tc cls cls_tys cls_kind
2004   = hang (ptext (sLit "Cannot derive well-kinded instance of form")
2005                 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
2006        2 (ptext (sLit "Class") <+> quotes (ppr cls)
2007             <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
2008
2009 derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
2010 derivingEtaErr cls cls_tys inst_ty
2011   = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
2012          nest 2 (ptext (sLit "instance (...) =>")
2013                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
2014
2015 derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc
2016 derivingThingErr newtype_deriving clas tys ty why
2017   = sep [(hang (ptext (sLit "Can't make a derived instance of"))
2018              2 (quotes (ppr pred))
2019           $$ nest 2 extra) <> colon,
2020          nest 2 why]
2021   where
2022     extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
2023           | otherwise        = empty
2024     pred = mkClassPred clas (tys ++ [ty])
2025
2026 derivingHiddenErr :: TyCon -> SDoc
2027 derivingHiddenErr tc
2028   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
2029        2 (ptext (sLit "so you cannot derive an instance for it"))
2030
2031 standaloneCtxt :: LHsType Name -> SDoc
2032 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
2033                        2 (quotes (ppr ty))
2034
2035 derivInstCtxt :: PredType -> MsgDoc
2036 derivInstCtxt pred
2037   = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
2038 \end{code}