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