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 stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
534 stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
535 all_constraints = stupid_constraints ++ ordinary_constraints
536 -- see Note [Data decl contexts] above
538 spec = DS { ds_loc = loc, ds_orig = orig
539 , ds_name = dfun_name, ds_tvs = tvs
540 , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
541 , ds_theta = mtheta `orElse` all_constraints
542 , ds_newtype = False }
544 ; return (if isJust mtheta then Just (Right spec) -- Specified context
545 else Just (Left spec)) } -- Infer context
548 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
549 -- The Typeable class is special in several ways
550 -- data T a b = ... deriving( Typeable )
552 -- instance Typeable2 T where ...
554 -- 1. There are no constraints in the instance
555 -- 2. There are no type variables either
556 -- 3. The actual class we want to generate isn't necessarily
557 -- Typeable; it depends on the arity of the type
558 | isNothing mtheta -- deriving on a data type decl
559 = do { checkTc (cls `hasKey` typeableClassKey)
560 (ptext SLIT("Use deriving( Typeable ) on a data type declaration"))
561 ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
562 ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
564 | otherwise -- standaone deriving
565 = do { checkTc (null tc_args)
566 (ptext SLIT("Derived typeable instance must be of form (Typeable")
567 <> int (tyConArity tycon) <+> ppr tycon <> rparen)
568 ; dfun_name <- new_dfun_name cls tycon
570 ; return (Just $ Right $
571 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
572 , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
573 , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
575 ------------------------------------------------------------------
576 -- Check side conditions that dis-allow derivability for particular classes
577 -- This is *apart* from the newtype-deriving mechanism
579 -- Here we get the representation tycon in case of family instances as it has
580 -- the data constructors - but we need to be careful to fall back to the
581 -- family tycon (with indexes) in error messages.
583 checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
584 checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
586 = Just ty_args_why -- e.g. deriving( Foo s )
588 = case sideConditions cls of
589 Just cond -> cond (mayDeriveDataTypeable, rep_tc)
590 Nothing -> Just non_std_why
592 ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
593 non_std_why = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
595 sideConditions :: Class -> Maybe Condition
597 | cls_key == eqClassKey = Just cond_std
598 | cls_key == ordClassKey = Just cond_std
599 | cls_key == readClassKey = Just cond_std
600 | cls_key == showClassKey = Just cond_std
601 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
602 | cls_key == ixClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
603 | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
604 | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
605 | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
606 | otherwise = Nothing
608 cls_key = getUnique cls
610 type Condition = (Bool, TyCon) -> Maybe SDoc
611 -- Bool is whether or not we are allowed to derive Data and Typeable
612 -- TyCon is the *representation* tycon if the
613 -- data type is an indexed one
616 orCond :: Condition -> Condition -> Condition
619 Nothing -> Nothing -- c1 succeeds
620 Just x -> case c2 tc of -- c1 fails
622 Just y -> Just (x $$ ptext SLIT(" and") $$ y)
625 andCond :: Condition -> Condition -> Condition
626 andCond c1 c2 tc = case c1 tc of
627 Nothing -> c2 tc -- c1 succeeds
628 Just x -> Just x -- c1 fails
630 cond_std :: Condition
632 | any (not . isVanillaDataCon) data_cons = Just existential_why
633 | null data_cons = Just no_cons_why
634 | otherwise = Nothing
636 data_cons = tyConDataCons rep_tc
637 no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
638 ptext SLIT("has no data constructors")
639 existential_why = quotes (pprSourceTyCon rep_tc) <+>
640 ptext SLIT("has non-Haskell-98 constructor(s)")
642 cond_isEnumeration :: Condition
643 cond_isEnumeration (_, rep_tc)
644 | isEnumerationTyCon rep_tc = Nothing
645 | otherwise = Just why
647 why = quotes (pprSourceTyCon rep_tc) <+>
648 ptext SLIT("has non-nullary constructors")
650 cond_isProduct :: Condition
651 cond_isProduct (_, rep_tc)
652 | isProductTyCon rep_tc = Nothing
653 | otherwise = Just why
655 why = quotes (pprSourceTyCon rep_tc) <+>
656 ptext SLIT("has more than one constructor")
658 cond_typeableOK :: Condition
659 -- OK for Typeable class
660 -- Currently: (a) args all of kind *
661 -- (b) 7 or fewer args
662 cond_typeableOK (_, rep_tc)
663 | tyConArity rep_tc > 7 = Just too_many
664 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
666 | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
667 | otherwise = Nothing
669 too_many = quotes (pprSourceTyCon rep_tc) <+>
670 ptext SLIT("has too many arguments")
671 bad_kind = quotes (pprSourceTyCon rep_tc) <+>
672 ptext SLIT("has arguments of kind other than `*'")
673 fam_inst = quotes (pprSourceTyCon rep_tc) <+>
674 ptext SLIT("is a type family")
676 cond_mayDeriveDataTypeable :: Condition
677 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
678 | mayDeriveDataTypeable = Nothing
679 | otherwise = Just why
681 why = ptext SLIT("You need -XDeriveDataTypeable to derive an instance for this class")
683 std_class_via_iso :: Class -> Bool
684 std_class_via_iso clas -- These standard classes can be derived for a newtype
685 -- using the isomorphism trick *even if no -fglasgow-exts*
686 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
687 -- Not Read/Show because they respect the type
688 -- Not Enum, because newtypes are never in Enum
691 new_dfun_name :: Class -> TyCon -> TcM Name
692 new_dfun_name clas tycon -- Just a simple wrapper
693 = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
694 -- The type passed to newDFunName is only used to generate
695 -- a suitable string; hence the empty type arg list
699 %************************************************************************
703 %************************************************************************
706 mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
707 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
709 -> TcRn (Maybe EarlyDerivSpec)
710 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
711 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
712 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
713 = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
714 ; dfun_name <- new_dfun_name cls tycon
716 ; let spec = DS { ds_loc = loc, ds_orig = orig
717 , ds_name = dfun_name, ds_tvs = dict_tvs
718 , ds_cls = cls, ds_tys = inst_tys
719 , ds_theta = mtheta `orElse` all_preds
720 , ds_newtype = True }
721 ; return (if isJust mtheta then Just (Right spec)
722 else Just (Left spec)) }
724 | isNothing mb_std_err -- Use the standard H98 method
725 = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
727 -- Otherwise we can't derive
728 | newtype_deriving = baleOut cant_derive_err -- Too hard
729 | otherwise = baleOut std_err -- Just complain about being a non-std instance
731 mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
732 std_err = derivingThingErr cls cls_tys tc_app $
733 vcat [fromJust mb_std_err,
734 ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
736 -- Here is the plan for newtype derivings. We see
737 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
738 -- where t is a type,
739 -- ak+1...an is a suffix of a1..an, and are all tyars
740 -- ak+1...an do not occur free in t, nor in the s1..sm
741 -- (C s1 ... sm) is a *partial applications* of class C
742 -- with the last parameter missing
743 -- (T a1 .. ak) matches the kind of C's last argument
744 -- (and hence so does t)
746 -- We generate the instance
747 -- instance forall ({a1..ak} u fvs(s1..sm)).
748 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
749 -- where T a1...ap is the partial application of
750 -- the LHS of the correct kind and p >= k
752 -- NB: the variables below are:
753 -- tc_tvs = [a1, ..., an]
754 -- tyvars_to_keep = [a1, ..., ak]
755 -- rep_ty = t ak .. an
756 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
757 -- tys = [s1, ..., sm]
760 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
761 -- We generate the instance
762 -- instance Monad (ST s) => Monad (T s) where
764 cls_tyvars = classTyVars cls
765 kind = tyVarKind (last cls_tyvars)
766 -- Kind of the thing we want to instance
767 -- e.g. argument kind of Monad, *->*
769 (arg_kinds, _) = splitKindFunTys kind
770 n_args_to_drop = length arg_kinds
771 -- Want to drop 1 arg from (T s a) and (ST s a)
772 -- to get instance Monad (ST s) => Monad (T s)
774 -- Note [newtype representation]
775 -- Need newTyConRhs *not* newTyConRep to get the representation
776 -- type, because the latter looks through all intermediate newtypes
778 -- newtype B = MkB Int
779 -- newtype A = MkA B deriving( Num )
780 -- We want the Num instance of B, *not* the Num instance of Int,
781 -- when making the Num instance of A!
782 rep_ty = newTyConInstRhs rep_tycon rep_tc_args
783 (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
785 n_tyargs_to_keep = tyConArity tycon - n_args_to_drop
786 dropped_tc_args = drop n_tyargs_to_keep tc_args
787 dropped_tvs = tyVarsOfTypes dropped_tc_args
789 n_args_to_keep = length rep_ty_args - n_args_to_drop
790 args_to_drop = drop n_args_to_keep rep_ty_args
791 args_to_keep = take n_args_to_keep rep_ty_args
793 rep_fn' = mkAppTys rep_fn args_to_keep
794 rep_tys = cls_tys ++ [rep_fn']
795 rep_pred = mkClassPred cls rep_tys
796 -- rep_pred is the representation dictionary, from where
797 -- we are gong to get all the methods for the newtype
800 tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)
802 -- Next we figure out what superclass dictionaries to use
803 -- See Note [Newtype deriving superclasses] above
805 inst_tys = cls_tys ++ [tc_app]
806 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
809 -- If there are no tyvars, there's no need
810 -- to abstract over the dictionaries we need
811 -- Example: newtype T = MkT Int deriving( C )
812 -- We get the derived instance
815 -- instance C Int => C T
816 dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs
817 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
819 -------------------------------------------------------------------
820 -- Figuring out whether we can only do this newtype-deriving thing
822 right_arity = length cls_tys + 1 == classArity cls
824 -- Never derive Read,Show,Typeable,Data this way
825 non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
826 can_derive_via_isomorphism
827 = not (getUnique cls `elem` non_iso_classes)
828 && right_arity -- Well kinded;
829 -- eg not: newtype T ... deriving( ST )
830 -- because ST needs *2* type params
831 && n_tyargs_to_keep >= 0 -- Type constructor has right kind:
832 -- eg not: newtype T = T Int deriving( Monad )
833 && n_args_to_keep >= 0 -- Rep type has right kind:
834 -- eg not: newtype T a = T Int deriving( Monad )
835 && eta_ok -- Eta reduction works
836 && not (isRecursiveTyCon tycon) -- Does not work for recursive tycons:
837 -- newtype A = MkA [A]
839 -- instance Eq [A] => Eq A !!
840 -- Here's a recursive newtype that's actually OK
841 -- newtype S1 = S1 [T1 ()]
842 -- newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
843 -- It's currently rejected. Oh well.
844 -- In fact we generate an instance decl that has method of form
845 -- meth @ instTy = meth @ repTy
846 -- (no coerce's). We'd need a coerce if we wanted to handle
847 -- recursive newtypes too
849 -- Check that eta reduction is OK
850 eta_ok = (args_to_drop `tcEqTypes` dropped_tc_args)
851 -- (a) the dropped-off args are identical in the source and rep type
852 -- newtype T a b = MkT (S [a] b) deriving( Monad )
853 -- Here the 'b' must be the same in the rep type (S [a] b)
855 && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
856 -- (b) the remaining type args do not mention any of the dropped
859 && (tyVarsOfTypes cls_tys `disjointVarSet` dropped_tvs)
860 -- (c) the type class args do not mention any of the dropped type
863 && all isTyVarTy dropped_tc_args
864 -- (d) in case of newtype family instances, the eta-dropped
865 -- arguments must be type variables (not more complex indexes)
867 cant_derive_err = derivingThingErr cls cls_tys tc_app
868 (vcat [ptext SLIT("even with cunning newtype deriving:"),
869 if isRecursiveTyCon tycon then
870 ptext SLIT("the newtype may be recursive")
872 if not right_arity then
873 quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1")
875 if not (n_tyargs_to_keep >= 0) then
876 ptext SLIT("the type constructor has wrong kind")
877 else if not (n_args_to_keep >= 0) then
878 ptext SLIT("the representation type has wrong kind")
879 else if not eta_ok then
880 ptext SLIT("the eta-reduction property does not hold")
886 %************************************************************************
888 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
890 %************************************************************************
892 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
893 terms, which is the final correct RHS for the corresponding original
897 Each (k,TyVarTy tv) in a solution constrains only a type
901 The (k,TyVarTy tv) pairs in a solution are canonically
902 ordered by sorting on type varible, tv, (major key) and then class, k,
907 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
909 inferInstanceContexts _ [] = return []
911 inferInstanceContexts oflag infer_specs
912 = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
913 ; iterate_deriv 1 initial_solutions }
915 ------------------------------------------------------------------
916 -- The initial solutions for the equations claim that each
917 -- instance has an empty context; this solution is certainly
918 -- in canonical form.
919 initial_solutions :: [ThetaType]
920 initial_solutions = [ [] | _ <- infer_specs ]
922 ------------------------------------------------------------------
923 -- iterate_deriv calculates the next batch of solutions,
924 -- compares it with the current one; finishes if they are the
925 -- same, otherwise recurses with the new solutions.
926 -- It fails if any iteration fails
927 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
928 iterate_deriv n current_solns
929 | n > 20 -- Looks as if we are in an infinite loop
930 -- This can happen if we have -fallow-undecidable-instances
931 -- (See TcSimplify.tcSimplifyDeriv.)
932 = pprPanic "solveDerivEqns: probable loop"
933 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
935 = do { -- Extend the inst info from the explicit instance decls
936 -- with the current set of solutions, and simplify each RHS
937 let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag)
938 current_solns infer_specs
939 ; new_solns <- checkNoErrs $
940 extendLocalInstEnv inst_specs $
941 mapM gen_soln infer_specs
943 ; if (current_solns == new_solns) then
944 return [ spec { ds_theta = soln }
945 | (spec, soln) <- zip infer_specs current_solns ]
947 iterate_deriv (n+1) new_solns }
949 ------------------------------------------------------------------
950 gen_soln :: DerivSpec -> TcM [PredType]
951 gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
952 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
954 addErrCtxt (derivInstCtxt clas inst_tys) $
955 do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
956 -- checkValidInstance tyvars theta clas inst_tys
957 -- Not necessary; see Note [Exotic derived instance contexts]
960 -- Check for a bizarre corner case, when the derived instance decl should
961 -- have form instance C a b => D (T a) where ...
962 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
963 -- of problems; in particular, it's hard to compare solutions for
964 -- equality when finding the fixpoint. So I just rule it out for now.
965 ; let tv_set = mkVarSet tyvars
966 weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
967 ; mapM_ (addErrTc . badDerivedPred) weird_preds
969 -- Claim: the result instance declaration is guaranteed valid
970 -- Hence no need to call:
971 -- checkValidInstance tyvars theta clas inst_tys
972 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
974 ------------------------------------------------------------------
975 mkInstance1 :: OverlapFlag -> DerivSpec -> Instance
976 mkInstance1 overlap_flag spec = mkInstance2 overlap_flag (ds_theta spec) spec
978 mkInstance2 :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
979 mkInstance2 overlap_flag theta
980 (DS { ds_name = dfun_name
981 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
982 = mkLocalInstance dfun overlap_flag
984 dfun = mkDictFunId dfun_name tyvars theta clas tys
987 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
988 -- Add new locally-defined instances; don't bother to check
989 -- for functional dependency errors -- that'll happen in TcInstDcls
990 extendLocalInstEnv dfuns thing_inside
991 = do { env <- getGblEnv
992 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
993 env' = env { tcg_inst_env = inst_env' }
994 ; setGblEnv env' thing_inside }
998 %************************************************************************
1000 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1002 %************************************************************************
1004 After all the trouble to figure out the required context for the
1005 derived instance declarations, all that's left is to chug along to
1006 produce them. They will then be shoved into @tcInstDecls2@, which
1007 will do all its usual business.
1009 There are lots of possibilities for code to generate. Here are
1010 various general remarks.
1015 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1016 ``you-couldn't-do-better-by-hand'' efficient.
1019 Deriving @Show@---also pretty common--- should also be reasonable good code.
1022 Deriving for the other classes isn't that common or that big a deal.
1029 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1032 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1035 We {\em normally} generate code only for the non-defaulted methods;
1036 there are some exceptions for @Eq@ and (especially) @Ord@...
1039 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1040 constructor's numeric (@Int#@) tag. These are generated by
1041 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1042 these is around is given by @hasCon2TagFun@.
1044 The examples under the different sections below will make this
1048 Much less often (really just for deriving @Ix@), we use a
1049 @_tag2con_<tycon>@ function. See the examples.
1052 We use the renamer!!! Reason: we're supposed to be
1053 producing @LHsBinds Name@ for the methods, but that means
1054 producing correctly-uniquified code on the fly. This is entirely
1055 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1056 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1057 the renamer. What a great hack!
1061 -- Generate the InstInfo for the required instance paired with the
1062 -- *representation* tycon for that instance,
1063 -- plus any auxiliary bindings required
1065 -- Representation tycons differ from the tycon in the instance signature in
1066 -- case of instances for indexed families.
1068 genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo, DerivAuxBinds)
1071 = return (InstInfo { iSpec = mkInstance1 oflag spec
1072 , iBinds = NewTypeDerived }, [])
1075 = do { fix_env <- getFixityEnv
1077 inst = mkInstance1 oflag spec
1078 (tyvars,_,clas,[ty]) = instanceHead inst
1079 clas_nm = className clas
1080 (visible_tycon, tyArgs) = tcSplitTyConApp ty
1082 -- In case of a family instance, we need to use the representation
1083 -- tycon (after all, it has the data constructors)
1084 ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
1085 ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
1087 -- Bring the right type variables into
1088 -- scope, and rename the method binds
1089 -- It's a bit yukky that we return *renamed* InstInfo, but
1090 -- *non-renamed* auxiliary bindings
1091 ; (rn_meth_binds, _fvs) <- discardWarnings $
1092 bindLocalNames (map Var.varName tyvars) $
1093 rnMethodBinds clas_nm (\_ -> []) [] meth_binds
1095 -- Build the InstInfo
1096 ; return (InstInfo { iSpec = inst,
1097 iBinds = VanillaInst rn_meth_binds [] },
1101 genDerivBinds :: Class -> FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1102 genDerivBinds clas fix_env tycon
1103 | className clas `elem` typeableClassNames
1104 = (gen_Typeable_binds tycon, [])
1107 = case assocMaybe gen_list (getUnique clas) of
1108 Just gen_fn -> gen_fn tycon
1109 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1111 gen_list :: [(Unique, TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1112 gen_list = [(eqClassKey, gen_Eq_binds)
1113 ,(ordClassKey, gen_Ord_binds)
1114 ,(enumClassKey, gen_Enum_binds)
1115 ,(boundedClassKey, gen_Bounded_binds)
1116 ,(ixClassKey, gen_Ix_binds)
1117 ,(showClassKey, gen_Show_binds fix_env)
1118 ,(readClassKey, gen_Read_binds fix_env)
1119 ,(dataClassKey, gen_Data_binds fix_env)
1124 %************************************************************************
1126 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1128 %************************************************************************
1131 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
1132 derivingThingErr clas tys ty why
1133 = sep [hsep [ptext SLIT("Can't make a derived instance of"),
1135 nest 2 (parens why)]
1137 pred = mkClassPred clas (tys ++ [ty])
1139 derivingHiddenErr :: TyCon -> SDoc
1140 derivingHiddenErr tc
1141 = hang (ptext SLIT("The data constructors of") <+> quotes (ppr tc) <+> ptext SLIT("are not all in scope"))
1142 2 (ptext SLIT("so you cannot derive an instance for it"))
1144 standaloneCtxt :: LHsType Name -> SDoc
1145 standaloneCtxt ty = hang (ptext SLIT("In the stand-alone deriving instance for"))
1148 derivInstCtxt :: Class -> [Type] -> Message
1149 derivInstCtxt clas inst_tys
1150 = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1152 badDerivedPred :: PredType -> Message
1154 = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
1155 ptext SLIT("type variables that are not data type parameters"),
1156 nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
1158 famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
1159 famInstNotFound tycon tys notExact
1160 = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
1162 msg = ptext $ if notExact
1163 then SLIT("No family instance exactly matching")
1164 else SLIT("More than one family instance for")