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