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