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