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