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