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