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