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