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