2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Handles @deriving@ clauses on @data@ declarations.
9 module TcDeriv ( tcDeriving ) where
11 #include "HsVersions.h"
19 import TcClassDcl( tcAddDeclCtxt ) -- Small helper
20 import TcGenDeriv -- Deriv stuff
52 %************************************************************************
56 %************************************************************************
60 1. Convert the decls (i.e. data/newtype deriving clauses,
61 plus standalone deriving) to [EarlyDerivSpec]
63 2. Infer the missing contexts for the Left DerivSpecs
65 3. Add the derived bindings, generating InstInfos
68 -- DerivSpec is purely local to this module
69 data DerivSpec = DS { ds_loc :: SrcSpan
70 , ds_orig :: InstOrigin
73 , ds_theta :: ThetaType
76 , ds_newtype :: Bool }
77 -- This spec implies a dfun declaration of the form
78 -- df :: forall tvs. theta => C tys
79 -- The Name is the name for the DFun we'll build
80 -- The tyvars bind all the variables in the theta
81 -- For family indexes, the tycon is the *family* tycon
82 -- (not the representation tycon)
84 -- ds_newtype = True <=> Newtype deriving
85 -- False <=> Vanilla deriving
87 type EarlyDerivSpec = Either DerivSpec DerivSpec
88 -- Left ds => the context for the instance should be inferred
89 -- In this case ds_theta is the list of all the
90 -- constraints needed, such as (Eq [a], Eq a)
91 -- The inference process is to reduce this to a
92 -- simpler form (e.g. Eq a)
94 -- Right ds => the exact context for the instance is supplied
95 -- by the programmer; it is ds_theta
97 pprDerivSpec :: DerivSpec -> SDoc
98 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
99 ds_cls = c, ds_tys = tys, ds_theta = rhs })
100 = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
101 <+> equals <+> ppr rhs)
105 Inferring missing contexts
106 ~~~~~~~~~~~~~~~~~~~~~~~~~~
109 data T a b = C1 (Foo a) (Bar b)
114 [NOTE: See end of these comments for what to do with
115 data (C a, D b) => T a b = ...
118 We want to come up with an instance declaration of the form
120 instance (Ping a, Pong b, ...) => Eq (T a b) where
123 It is pretty easy, albeit tedious, to fill in the code "...". The
124 trick is to figure out what the context for the instance decl is,
125 namely @Ping@, @Pong@ and friends.
127 Let's call the context reqd for the T instance of class C at types
128 (a,b, ...) C (T a b). Thus:
130 Eq (T a b) = (Ping a, Pong b, ...)
132 Now we can get a (recursive) equation from the @data@ decl:
134 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
135 u Eq (T b a) u Eq Int -- From C2
136 u Eq (T a a) -- From C3
138 Foo and Bar may have explicit instances for @Eq@, in which case we can
139 just substitute for them. Alternatively, either or both may have
140 their @Eq@ instances given by @deriving@ clauses, in which case they
141 form part of the system of equations.
143 Now all we need do is simplify and solve the equations, iterating to
144 find the least fixpoint. Notice that the order of the arguments can
145 switch around, as here in the recursive calls to T.
147 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
151 Eq (T a b) = {} -- The empty set
154 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
155 u Eq (T b a) u Eq Int -- From C2
156 u Eq (T a a) -- From C3
158 After simplification:
159 = Eq a u Ping b u {} u {} u {}
164 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
165 u Eq (T b a) u Eq Int -- From C2
166 u Eq (T a a) -- From C3
168 After simplification:
173 = Eq a u Ping b u Eq b u Ping a
175 The next iteration gives the same result, so this is the fixpoint. We
176 need to make a canonical form of the RHS to ensure convergence. We do
177 this by simplifying the RHS to a form in which
179 - the classes constrain only tyvars
180 - the list is sorted by tyvar (major key) and then class (minor key)
181 - no duplicates, of course
183 So, here are the synonyms for the ``equation'' structures:
186 Note [Data decl contexts]
187 ~~~~~~~~~~~~~~~~~~~~~~~~~
190 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
192 We will need an instance decl like:
194 instance (Read a, RealFloat a) => Read (Complex a) where
197 The RealFloat in the context is because the read method for Complex is bound
198 to construct a Complex, and doing that requires that the argument type is
201 But this ain't true for Show, Eq, Ord, etc, since they don't construct
202 a Complex; they only take them apart.
204 Our approach: identify the offending classes, and add the data type
205 context to the instance decl. The "offending classes" are
209 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
210 pattern matching against a constructor from a data type with a context
211 gives rise to the constraints for that context -- or at least the thinned
212 version. So now all classes are "offending".
214 Note [Newtype deriving]
215 ~~~~~~~~~~~~~~~~~~~~~~~
219 newtype T = T Char deriving( C [a] )
221 Notice the free 'a' in the deriving. We have to fill this out to
222 newtype T = T Char deriving( forall a. C [a] )
224 And then translate it to:
225 instance C [a] Char => C [a] T where ...
228 Note [Newtype deriving superclasses]
229 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
230 (See also Trac #1220 for an interesting exchange on newtype
231 deriving and superclasses.)
233 The 'tys' here come from the partial application in the deriving
234 clause. The last arg is the new instance type.
236 We must pass the superclasses; the newtype might be an instance
237 of them in a different way than the representation type
238 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
239 Then the Show instance is not done via isomorphism; it shows
241 The Num instance is derived via isomorphism, but the Show superclass
242 dictionary must the Show instance for Foo, *not* the Show dictionary
243 gotten from the Num dictionary. So we must build a whole new dictionary
244 not just use the Num one. The instance we want is something like:
245 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
248 There may be a coercion needed which we get from the tycon for the newtype
249 when the dict is constructed in TcInstDcls.tcInstDecl2
254 %************************************************************************
256 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
258 %************************************************************************
261 tcDeriving :: [LTyClDecl Name] -- All type constructors
262 -> [LInstDecl Name] -- All instance declarations
263 -> [LDerivDecl Name] -- All stand-alone deriving declarations
264 -> TcM ([InstInfo], -- The generated "instance decls"
265 HsValBinds Name) -- Extra generated top-level bindings
267 tcDeriving tycl_decls inst_decls deriv_decls
268 = recoverM (returnM ([], emptyValBindsOut)) $
269 do { -- Fish the "deriving"-related information out of the TcEnv
270 -- And make the necessary "equations".
271 ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
273 ; overlap_flag <- getOverlapFlag
274 ; let (infer_specs, given_specs) = splitEithers early_specs
275 ; (insts1, aux_binds1) <- mapAndUnzipM (genInst overlap_flag) given_specs
277 ; final_specs <- extendLocalInstEnv (map iSpec insts1) $
278 inferInstanceContexts overlap_flag infer_specs
280 ; (insts2, aux_binds2) <- mapAndUnzipM (genInst overlap_flag) final_specs
282 ; is_boot <- tcIsHsBoot
283 ; rn_binds <- makeAuxBinds is_boot tycl_decls
284 (concat aux_binds1 ++ concat aux_binds2)
286 ; let inst_info = insts1 ++ insts2
289 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
290 (ddump_deriving inst_info rn_binds))
292 ; return (inst_info, rn_binds) }
294 ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc
295 ddump_deriving inst_infos extra_binds
296 = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
298 makeAuxBinds :: Bool -> [LTyClDecl Name] -> DerivAuxBinds -> TcM (HsValBinds Name)
299 makeAuxBinds is_boot tycl_decls deriv_aux_binds
300 | is_boot -- If we are compiling a hs-boot file,
301 -- don't generate any derived bindings
302 = return emptyValBindsOut
305 = do { let aux_binds = listToBag (map genAuxBind (rm_dups [] deriv_aux_binds))
306 -- Generate any extra not-one-inst-decl-specific binds,
307 -- notably "con2tag" and/or "tag2con" functions.
309 -- Generate the generic to/from functions from each type declaration
310 ; gen_binds <- mkGenericBinds tycl_decls
312 -- Rename these extra bindings, discarding warnings about unused bindings etc
313 -- Type signatures in patterns are used in the generic binds
315 setOptM Opt_PatternSignatures $
316 do { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn aux_binds [])
317 ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
318 ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
320 ; return (rn_deriv `plusHsValBinds` rn_gen) } }
322 -- Remove duplicate requests for auxilliary bindings
324 rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
325 | otherwise = rm_dups (b:acc) bs
327 -----------------------------------------
328 mkGenericBinds :: [LTyClDecl Name] -> TcM (LHsBinds RdrName)
329 mkGenericBinds tycl_decls
330 = do { tcs <- mapM tcLookupTyCon
332 L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls]
333 -- We are only interested in the data type declarations
334 ; return (unionManyBags [ mkTyConGenericBinds tc |
335 tc <- tcs, tyConHasGenerics tc ]) }
336 -- And then only in the ones whose 'has-generics' flag is on
340 %************************************************************************
342 From HsSyn to DerivSpec
344 %************************************************************************
346 @makeDerivSpecs@ fishes around to find the info about needed derived
347 instances. Complicating factors:
350 We can only derive @Enum@ if the data type is an enumeration
351 type (all nullary data constructors).
354 We can only derive @Ix@ if the data type is an enumeration {\em
355 or} has just one data constructor (e.g., tuples).
358 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
362 makeDerivSpecs :: [LTyClDecl Name]
365 -> TcM [EarlyDerivSpec]
367 makeDerivSpecs tycl_decls inst_decls deriv_decls
368 = do { eqns1 <- mapAndRecoverM deriveTyData $
369 extractTyDataPreds tycl_decls ++
370 [ pd -- traverse assoc data families
371 | L _ (InstDecl _ _ _ ats) <- inst_decls
372 , pd <- extractTyDataPreds ats ]
373 ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
374 ; return (catMaybes (eqns1 ++ eqns2)) }
376 extractTyDataPreds decls =
377 [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
380 ------------------------------------------------------------------
381 deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec)
382 -- Standalone deriving declarations
383 -- e.g. deriving instance show a => Show (T a)
384 -- Rather like tcLocalInstDecl
385 deriveStandalone (L loc (DerivDecl deriv_ty))
387 addErrCtxt (standaloneCtxt deriv_ty) $
388 do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
389 ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
390 ; traceTc (text "standalone deriving;"
391 <+> text "tvs:" <+> ppr tvs
392 <+> text "theta:" <+> ppr theta
393 <+> text "tau:" <+> ppr tau)
394 ; (cls, inst_tys) <- checkValidInstHead tau
395 ; let cls_tys = take (length inst_tys - 1) inst_tys
396 inst_ty = last inst_tys
398 ; traceTc (text "standalone deriving;"
399 <+> text "class:" <+> ppr cls
400 <+> text "class types:" <+> ppr cls_tys
401 <+> text "type:" <+> ppr inst_ty)
402 ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
405 ------------------------------------------------------------------
406 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)
407 deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name,
408 tcdTyVars = tv_names,
409 tcdTyPats = ty_pats }))
412 do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
413 hs_app = nlHsTyConApp tycon_name hs_ty_args
414 -- We get kinding info for the tyvars by typechecking (T a b)
415 -- Hence forming a tycon application and then dis-assembling it
416 ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
417 ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
418 -- the type variables for the type constructor
419 do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
420 -- The "deriv_pred" is a LHsType to take account of the fact that for
421 -- newtype deriving we allow deriving (forall a. C [a]).
422 ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }
425 = panic "derivTyData" -- Caller ensures that only TyData can happen
427 ------------------------------------------------------------------
428 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
429 -> Maybe ThetaType -- Just => context supplied (standalone deriving)
430 -- Nothing => context inferred (deriving on data decl)
431 -> TcRn (Maybe EarlyDerivSpec)
432 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
433 | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
435 -- For standalone deriving (mtheta /= Nothing),
436 -- check that all the data constructors are in scope
437 -- By this time we know that the thing is algebraic
438 -- because we've called checkInstHead in derivingStandalone
439 rdr_env <- getGlobalRdrEnv
440 ; let hidden_data_cons = filter not_in_scope (tyConDataCons tycon)
441 not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
442 ; checkTc (isNothing mtheta || null hidden_data_cons)
443 (derivingHiddenErr tycon)
445 ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
446 ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
448 ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
450 -- Be careful to test rep_tc here: in the case of families, we want
451 -- to check the instance tycon, not the family tycon
452 ; if isDataTyCon rep_tc then
453 mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
454 tycon tc_args rep_tc rep_tc_args mtheta
456 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
458 tycon tc_args rep_tc rep_tc_args mtheta }
460 = baleOut (derivingThingErr cls cls_tys tc_app
461 (ptext SLIT("Last argument of the instance must be a type application")))
463 baleOut :: Message -> TcM (Maybe a)
464 baleOut err = do { addErrTc err; return Nothing }
467 Auxiliary lookup wrapper which requires that looked up family instances are
468 not type instances. If called with a vanilla tycon, the old type application
472 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
473 tcLookupFamInstExact tycon tys
474 | not (isOpenTyCon tycon)
475 = return (tycon, tys)
477 = do { maybeFamInst <- tcLookupFamInst tycon tys
478 ; case maybeFamInst of
479 Nothing -> famInstNotFound tycon tys False
480 Just famInst@(_, rep_tys)
481 | not variable_only_subst -> famInstNotFound tycon tys True
482 | otherwise -> return famInst
484 tvs = map (Type.getTyVar
485 "TcDeriv.tcLookupFamInstExact")
487 variable_only_subst = all Type.isTyVarTy rep_tys &&
488 sizeVarSet (mkVarSet tvs) == length tvs
489 -- renaming may have no repetitions
494 %************************************************************************
498 %************************************************************************
501 mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
502 -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType
503 -> TcRn (Maybe EarlyDerivSpec) -- Return 'Nothing' if error
505 mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
506 tycon tc_args rep_tc rep_tc_args mtheta
507 | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
508 -- NB: pass the *representation* tycon to checkSideConditions
509 = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
512 = ASSERT( null cls_tys )
513 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
515 mk_data_eqn, mk_typeable_eqn
516 :: InstOrigin -> [TyVar] -> Class
517 -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
518 -> TcM (Maybe EarlyDerivSpec)
519 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
520 | getName cls `elem` typeableClassNames
521 = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
524 = do { dfun_name <- new_dfun_name cls tycon
526 ; let ordinary_constraints
527 = [ mkClassPred cls [arg_ty]
528 | data_con <- tyConDataCons rep_tc,
529 arg_ty <- ASSERT( isVanillaDataCon data_con )
530 dataConInstOrigArgTys data_con rep_tc_args,
531 not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
533 -- See Note [Superclasses of derived instance]
534 sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
536 inst_tys = [mkTyConApp tycon tc_args]
538 stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
539 stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
540 all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
542 spec = DS { ds_loc = loc, ds_orig = orig
543 , ds_name = dfun_name, ds_tvs = tvs
544 , ds_cls = cls, ds_tys = inst_tys
545 , ds_theta = mtheta `orElse` all_constraints
546 , ds_newtype = False }
548 ; return (if isJust mtheta then Just (Right spec) -- Specified context
549 else Just (Left spec)) } -- Infer context
551 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
552 -- The Typeable class is special in several ways
553 -- data T a b = ... deriving( Typeable )
555 -- instance Typeable2 T where ...
557 -- 1. There are no constraints in the instance
558 -- 2. There are no type variables either
559 -- 3. The actual class we want to generate isn't necessarily
560 -- Typeable; it depends on the arity of the type
561 | isNothing mtheta -- deriving on a data type decl
562 = do { checkTc (cls `hasKey` typeableClassKey)
563 (ptext SLIT("Use deriving( Typeable ) on a data type declaration"))
564 ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
565 ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
567 | otherwise -- standaone deriving
568 = do { checkTc (null tc_args)
569 (ptext SLIT("Derived typeable instance must be of form (Typeable")
570 <> int (tyConArity tycon) <+> ppr tycon <> rparen)
571 ; dfun_name <- new_dfun_name cls tycon
573 ; return (Just $ Right $
574 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
575 , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
576 , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
578 ------------------------------------------------------------------
579 -- Check side conditions that dis-allow derivability for particular classes
580 -- This is *apart* from the newtype-deriving mechanism
582 -- Here we get the representation tycon in case of family instances as it has
583 -- the data constructors - but we need to be careful to fall back to the
584 -- family tycon (with indexes) in error messages.
586 checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
587 checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
589 = Just ty_args_why -- e.g. deriving( Foo s )
591 = case sideConditions cls of
592 Just cond -> cond (mayDeriveDataTypeable, rep_tc)
593 Nothing -> Just non_std_why
595 ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
596 non_std_why = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
598 sideConditions :: Class -> Maybe Condition
600 | cls_key == eqClassKey = Just cond_std
601 | cls_key == ordClassKey = Just cond_std
602 | cls_key == readClassKey = Just cond_std
603 | cls_key == showClassKey = Just cond_std
604 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
605 | cls_key == ixClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
606 | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
607 | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
608 | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
609 | otherwise = Nothing
611 cls_key = getUnique cls
613 type Condition = (Bool, TyCon) -> Maybe SDoc
614 -- Bool is whether or not we are allowed to derive Data and Typeable
615 -- TyCon is the *representation* tycon if the
616 -- data type is an indexed one
619 orCond :: Condition -> Condition -> Condition
622 Nothing -> Nothing -- c1 succeeds
623 Just x -> case c2 tc of -- c1 fails
625 Just y -> Just (x $$ ptext SLIT(" and") $$ y)
628 andCond :: Condition -> Condition -> Condition
629 andCond c1 c2 tc = case c1 tc of
630 Nothing -> c2 tc -- c1 succeeds
631 Just x -> Just x -- c1 fails
633 cond_std :: Condition
635 | any (not . isVanillaDataCon) data_cons = Just existential_why
636 | null data_cons = Just no_cons_why
637 | otherwise = Nothing
639 data_cons = tyConDataCons rep_tc
640 no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
641 ptext SLIT("has no data constructors")
642 existential_why = quotes (pprSourceTyCon rep_tc) <+>
643 ptext SLIT("has non-Haskell-98 constructor(s)")
645 cond_isEnumeration :: Condition
646 cond_isEnumeration (_, rep_tc)
647 | isEnumerationTyCon rep_tc = Nothing
648 | otherwise = Just why
650 why = quotes (pprSourceTyCon rep_tc) <+>
651 ptext SLIT("has non-nullary constructors")
653 cond_isProduct :: Condition
654 cond_isProduct (_, rep_tc)
655 | isProductTyCon rep_tc = Nothing
656 | otherwise = Just why
658 why = quotes (pprSourceTyCon rep_tc) <+>
659 ptext SLIT("has more than one constructor")
661 cond_typeableOK :: Condition
662 -- OK for Typeable class
663 -- Currently: (a) args all of kind *
664 -- (b) 7 or fewer args
665 cond_typeableOK (_, rep_tc)
666 | tyConArity rep_tc > 7 = Just too_many
667 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
669 | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
670 | otherwise = Nothing
672 too_many = quotes (pprSourceTyCon rep_tc) <+>
673 ptext SLIT("has too many arguments")
674 bad_kind = quotes (pprSourceTyCon rep_tc) <+>
675 ptext SLIT("has arguments of kind other than `*'")
676 fam_inst = quotes (pprSourceTyCon rep_tc) <+>
677 ptext SLIT("is a type family")
679 cond_mayDeriveDataTypeable :: Condition
680 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
681 | mayDeriveDataTypeable = Nothing
682 | otherwise = Just why
684 why = ptext SLIT("You need -XDeriveDataTypeable to derive an instance for this class")
686 std_class_via_iso :: Class -> Bool
687 std_class_via_iso clas -- These standard classes can be derived for a newtype
688 -- using the isomorphism trick *even if no -fglasgow-exts*
689 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
690 -- Not Read/Show because they respect the type
691 -- Not Enum, because newtypes are never in Enum
694 new_dfun_name :: Class -> TyCon -> TcM Name
695 new_dfun_name clas tycon -- Just a simple wrapper
696 = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
697 -- The type passed to newDFunName is only used to generate
698 -- a suitable string; hence the empty type arg list
701 Note [Superclasses of derived instance]
702 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
703 In general, a derived instance decl needs the superclasses of the derived
704 class too. So if we have
705 data T a = ...deriving( Ord )
706 then the initial context for Ord (T a) should include Eq (T a). Often this is
707 redundant; we'll also generate an Ord constraint for each constructor argument,
708 and that will probably generate enough constraints to make the Eq (T a) constraint
709 be satisfied too. But not always; consider:
715 data T a = MkT (S a) deriving( Ord )
716 instance Num a => Eq (T a)
718 The derived instance for (Ord (T a)) must have a (Num a) constraint!
720 data T a = MkT deriving( Data, Typeable )
721 Here there *is* no argument field, but we must nevertheless generate
722 a context for the Data instances:
723 instance Typable a => Data (T a) where ...
726 %************************************************************************
730 %************************************************************************
733 mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
734 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
736 -> TcRn (Maybe EarlyDerivSpec)
737 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
738 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
739 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
740 = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
741 ; dfun_name <- new_dfun_name cls tycon
743 ; let spec = DS { ds_loc = loc, ds_orig = orig
744 , ds_name = dfun_name, ds_tvs = dict_tvs
745 , ds_cls = cls, ds_tys = inst_tys
746 , ds_theta = mtheta `orElse` all_preds
747 , ds_newtype = True }
748 ; return (if isJust mtheta then Just (Right spec)
749 else Just (Left spec)) }
751 | isNothing mb_std_err -- Use the standard H98 method
752 = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
754 -- Otherwise we can't derive
755 | newtype_deriving = baleOut cant_derive_err -- Too hard
756 | otherwise = baleOut std_err -- Just complain about being a non-std instance
758 mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
759 std_err = derivingThingErr cls cls_tys tc_app $
760 vcat [fromJust mb_std_err,
761 ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
763 -- Here is the plan for newtype derivings. We see
764 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
765 -- where t is a type,
766 -- ak+1...an is a suffix of a1..an, and are all tyars
767 -- ak+1...an do not occur free in t, nor in the s1..sm
768 -- (C s1 ... sm) is a *partial applications* of class C
769 -- with the last parameter missing
770 -- (T a1 .. ak) matches the kind of C's last argument
771 -- (and hence so does t)
773 -- We generate the instance
774 -- instance forall ({a1..ak} u fvs(s1..sm)).
775 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
776 -- where T a1...ap is the partial application of
777 -- the LHS of the correct kind and p >= k
779 -- NB: the variables below are:
780 -- tc_tvs = [a1, ..., an]
781 -- tyvars_to_keep = [a1, ..., ak]
782 -- rep_ty = t ak .. an
783 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
784 -- tys = [s1, ..., sm]
787 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
788 -- We generate the instance
789 -- instance Monad (ST s) => Monad (T s) where
791 cls_tyvars = classTyVars cls
792 kind = tyVarKind (last cls_tyvars)
793 -- Kind of the thing we want to instance
794 -- e.g. argument kind of Monad, *->*
796 (arg_kinds, _) = splitKindFunTys kind
797 n_args_to_drop = length arg_kinds
798 -- Want to drop 1 arg from (T s a) and (ST s a)
799 -- to get instance Monad (ST s) => Monad (T s)
801 -- Note [Newtype representation]
802 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
803 -- Need newTyConRhs (*not* a recursive representation finder)
804 -- to get the representation type. For example
805 -- newtype B = MkB Int
806 -- newtype A = MkA B deriving( Num )
807 -- We want the Num instance of B, *not* the Num instance of Int,
808 -- when making the Num instance of A!
809 rep_ty = newTyConInstRhs rep_tycon rep_tc_args
810 (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
812 n_tyargs_to_keep = tyConArity tycon - n_args_to_drop
813 dropped_tc_args = drop n_tyargs_to_keep tc_args
814 dropped_tvs = tyVarsOfTypes dropped_tc_args
816 n_args_to_keep = length rep_ty_args - n_args_to_drop
817 args_to_drop = drop n_args_to_keep rep_ty_args
818 args_to_keep = take n_args_to_keep rep_ty_args
820 rep_fn' = mkAppTys rep_fn args_to_keep
821 rep_tys = cls_tys ++ [rep_fn']
822 rep_pred = mkClassPred cls rep_tys
823 -- rep_pred is the representation dictionary, from where
824 -- we are gong to get all the methods for the newtype
827 tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)
829 -- Next we figure out what superclass dictionaries to use
830 -- See Note [Newtype deriving superclasses] above
832 inst_tys = cls_tys ++ [tc_app]
833 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
836 -- If there are no tyvars, there's no need
837 -- to abstract over the dictionaries we need
838 -- Example: newtype T = MkT Int deriving( C )
839 -- We get the derived instance
842 -- instance C Int => C T
843 dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs
844 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
846 -------------------------------------------------------------------
847 -- Figuring out whether we can only do this newtype-deriving thing
849 right_arity = length cls_tys + 1 == classArity cls
851 -- Never derive Read,Show,Typeable,Data this way
852 non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
853 can_derive_via_isomorphism
854 = not (getUnique cls `elem` non_iso_classes)
855 && right_arity -- Well kinded;
856 -- eg not: newtype T ... deriving( ST )
857 -- because ST needs *2* type params
858 && n_tyargs_to_keep >= 0 -- Type constructor has right kind:
859 -- eg not: newtype T = T Int deriving( Monad )
860 && n_args_to_keep >= 0 -- Rep type has right kind:
861 -- eg not: newtype T a = T Int deriving( Monad )
862 && eta_ok -- Eta reduction works
863 && not (isRecursiveTyCon tycon) -- Does not work for recursive tycons:
864 -- newtype A = MkA [A]
866 -- instance Eq [A] => Eq A !!
867 -- Here's a recursive newtype that's actually OK
868 -- newtype S1 = S1 [T1 ()]
869 -- newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
870 -- It's currently rejected. Oh well.
871 -- In fact we generate an instance decl that has method of form
872 -- meth @ instTy = meth @ repTy
873 -- (no coerce's). We'd need a coerce if we wanted to handle
874 -- recursive newtypes too
876 -- Check that eta reduction is OK
877 eta_ok = (args_to_drop `tcEqTypes` dropped_tc_args)
878 -- (a) the dropped-off args are identical in the source and rep type
879 -- newtype T a b = MkT (S [a] b) deriving( Monad )
880 -- Here the 'b' must be the same in the rep type (S [a] b)
882 && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
883 -- (b) the remaining type args do not mention any of the dropped
886 && (tyVarsOfTypes cls_tys `disjointVarSet` dropped_tvs)
887 -- (c) the type class args do not mention any of the dropped type
890 && all isTyVarTy dropped_tc_args
891 -- (d) in case of newtype family instances, the eta-dropped
892 -- arguments must be type variables (not more complex indexes)
894 cant_derive_err = derivingThingErr cls cls_tys tc_app
895 (vcat [ptext SLIT("even with cunning newtype deriving:"),
896 if isRecursiveTyCon tycon then
897 ptext SLIT("the newtype may be recursive")
899 if not right_arity then
900 quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1")
902 if not (n_tyargs_to_keep >= 0) then
903 ptext SLIT("the type constructor has wrong kind")
904 else if not (n_args_to_keep >= 0) then
905 ptext SLIT("the representation type has wrong kind")
906 else if not eta_ok then
907 ptext SLIT("the eta-reduction property does not hold")
913 %************************************************************************
915 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
917 %************************************************************************
919 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
920 terms, which is the final correct RHS for the corresponding original
924 Each (k,TyVarTy tv) in a solution constrains only a type
928 The (k,TyVarTy tv) pairs in a solution are canonically
929 ordered by sorting on type varible, tv, (major key) and then class, k,
934 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
936 inferInstanceContexts _ [] = return []
938 inferInstanceContexts oflag infer_specs
939 = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
940 ; iterate_deriv 1 initial_solutions }
942 ------------------------------------------------------------------
943 -- The initial solutions for the equations claim that each
944 -- instance has an empty context; this solution is certainly
945 -- in canonical form.
946 initial_solutions :: [ThetaType]
947 initial_solutions = [ [] | _ <- infer_specs ]
949 ------------------------------------------------------------------
950 -- iterate_deriv calculates the next batch of solutions,
951 -- compares it with the current one; finishes if they are the
952 -- same, otherwise recurses with the new solutions.
953 -- It fails if any iteration fails
954 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
955 iterate_deriv n current_solns
956 | n > 20 -- Looks as if we are in an infinite loop
957 -- This can happen if we have -fallow-undecidable-instances
958 -- (See TcSimplify.tcSimplifyDeriv.)
959 = pprPanic "solveDerivEqns: probable loop"
960 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
962 = do { -- Extend the inst info from the explicit instance decls
963 -- with the current set of solutions, and simplify each RHS
964 let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag)
965 current_solns infer_specs
966 ; new_solns <- checkNoErrs $
967 extendLocalInstEnv inst_specs $
968 mapM gen_soln infer_specs
970 ; if (current_solns == new_solns) then
971 return [ spec { ds_theta = soln }
972 | (spec, soln) <- zip infer_specs current_solns ]
974 iterate_deriv (n+1) new_solns }
976 ------------------------------------------------------------------
977 gen_soln :: DerivSpec -> TcM [PredType]
978 gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
979 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
981 addErrCtxt (derivInstCtxt clas inst_tys) $
982 do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
983 -- checkValidInstance tyvars theta clas inst_tys
984 -- Not necessary; see Note [Exotic derived instance contexts]
987 -- Check for a bizarre corner case, when the derived instance decl should
988 -- have form instance C a b => D (T a) where ...
989 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
990 -- of problems; in particular, it's hard to compare solutions for
991 -- equality when finding the fixpoint. So I just rule it out for now.
992 ; let tv_set = mkVarSet tyvars
993 weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
994 ; mapM_ (addErrTc . badDerivedPred) weird_preds
996 -- Claim: the result instance declaration is guaranteed valid
997 -- Hence no need to call:
998 -- checkValidInstance tyvars theta clas inst_tys
999 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
1001 ------------------------------------------------------------------
1002 mkInstance1 :: OverlapFlag -> DerivSpec -> Instance
1003 mkInstance1 overlap_flag spec = mkInstance2 overlap_flag (ds_theta spec) spec
1005 mkInstance2 :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1006 mkInstance2 overlap_flag theta
1007 (DS { ds_name = dfun_name
1008 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1009 = mkLocalInstance dfun overlap_flag
1011 dfun = mkDictFunId dfun_name tyvars theta clas tys
1014 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1015 -- Add new locally-defined instances; don't bother to check
1016 -- for functional dependency errors -- that'll happen in TcInstDcls
1017 extendLocalInstEnv dfuns thing_inside
1018 = do { env <- getGblEnv
1019 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1020 env' = env { tcg_inst_env = inst_env' }
1021 ; setGblEnv env' thing_inside }
1025 %************************************************************************
1027 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1029 %************************************************************************
1031 After all the trouble to figure out the required context for the
1032 derived instance declarations, all that's left is to chug along to
1033 produce them. They will then be shoved into @tcInstDecls2@, which
1034 will do all its usual business.
1036 There are lots of possibilities for code to generate. Here are
1037 various general remarks.
1042 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1043 ``you-couldn't-do-better-by-hand'' efficient.
1046 Deriving @Show@---also pretty common--- should also be reasonable good code.
1049 Deriving for the other classes isn't that common or that big a deal.
1056 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1059 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1062 We {\em normally} generate code only for the non-defaulted methods;
1063 there are some exceptions for @Eq@ and (especially) @Ord@...
1066 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1067 constructor's numeric (@Int#@) tag. These are generated by
1068 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1069 these is around is given by @hasCon2TagFun@.
1071 The examples under the different sections below will make this
1075 Much less often (really just for deriving @Ix@), we use a
1076 @_tag2con_<tycon>@ function. See the examples.
1079 We use the renamer!!! Reason: we're supposed to be
1080 producing @LHsBinds Name@ for the methods, but that means
1081 producing correctly-uniquified code on the fly. This is entirely
1082 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1083 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1084 the renamer. What a great hack!
1088 -- Generate the InstInfo for the required instance paired with the
1089 -- *representation* tycon for that instance,
1090 -- plus any auxiliary bindings required
1092 -- Representation tycons differ from the tycon in the instance signature in
1093 -- case of instances for indexed families.
1095 genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo, DerivAuxBinds)
1098 = return (InstInfo { iSpec = mkInstance1 oflag spec
1099 , iBinds = NewTypeDerived }, [])
1102 = do { fix_env <- getFixityEnv
1104 inst = mkInstance1 oflag spec
1105 (tyvars,_,clas,[ty]) = instanceHead inst
1106 clas_nm = className clas
1107 (visible_tycon, tyArgs) = tcSplitTyConApp ty
1109 -- In case of a family instance, we need to use the representation
1110 -- tycon (after all, it has the data constructors)
1111 ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
1112 ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
1114 -- Bring the right type variables into
1115 -- scope, and rename the method binds
1116 -- It's a bit yukky that we return *renamed* InstInfo, but
1117 -- *non-renamed* auxiliary bindings
1118 ; (rn_meth_binds, _fvs) <- discardWarnings $
1119 bindLocalNames (map Var.varName tyvars) $
1120 rnMethodBinds clas_nm (\_ -> []) [] meth_binds
1122 -- Build the InstInfo
1123 ; return (InstInfo { iSpec = inst,
1124 iBinds = VanillaInst rn_meth_binds [] },
1128 genDerivBinds :: Class -> FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1129 genDerivBinds clas fix_env tycon
1130 | className clas `elem` typeableClassNames
1131 = (gen_Typeable_binds tycon, [])
1134 = case assocMaybe gen_list (getUnique clas) of
1135 Just gen_fn -> gen_fn tycon
1136 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1138 gen_list :: [(Unique, TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1139 gen_list = [(eqClassKey, gen_Eq_binds)
1140 ,(ordClassKey, gen_Ord_binds)
1141 ,(enumClassKey, gen_Enum_binds)
1142 ,(boundedClassKey, gen_Bounded_binds)
1143 ,(ixClassKey, gen_Ix_binds)
1144 ,(showClassKey, gen_Show_binds fix_env)
1145 ,(readClassKey, gen_Read_binds fix_env)
1146 ,(dataClassKey, gen_Data_binds fix_env)
1151 %************************************************************************
1153 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1155 %************************************************************************
1158 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
1159 derivingThingErr clas tys ty why
1160 = sep [hsep [ptext SLIT("Can't make a derived instance of"),
1162 nest 2 (parens why)]
1164 pred = mkClassPred clas (tys ++ [ty])
1166 derivingHiddenErr :: TyCon -> SDoc
1167 derivingHiddenErr tc
1168 = hang (ptext SLIT("The data constructors of") <+> quotes (ppr tc) <+> ptext SLIT("are not all in scope"))
1169 2 (ptext SLIT("so you cannot derive an instance for it"))
1171 standaloneCtxt :: LHsType Name -> SDoc
1172 standaloneCtxt ty = hang (ptext SLIT("In the stand-alone deriving instance for"))
1175 derivInstCtxt :: Class -> [Type] -> Message
1176 derivInstCtxt clas inst_tys
1177 = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1179 badDerivedPred :: PredType -> Message
1181 = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
1182 ptext SLIT("type variables that are not data type parameters"),
1183 nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
1185 famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
1186 famInstNotFound tycon tys notExact
1187 = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
1189 msg = ptext $ if notExact
1190 then SLIT("No family instance exactly matching")
1191 else SLIT("More than one family instance for")