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