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