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