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