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