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