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