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 %************************************************************************
54 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
56 %************************************************************************
60 data T a b = C1 (Foo a) (Bar b)
65 [NOTE: See end of these comments for what to do with
66 data (C a, D b) => T a b = ...
69 We want to come up with an instance declaration of the form
71 instance (Ping a, Pong b, ...) => Eq (T a b) where
74 It is pretty easy, albeit tedious, to fill in the code "...". The
75 trick is to figure out what the context for the instance decl is,
76 namely @Ping@, @Pong@ and friends.
78 Let's call the context reqd for the T instance of class C at types
79 (a,b, ...) C (T a b). Thus:
81 Eq (T a b) = (Ping a, Pong b, ...)
83 Now we can get a (recursive) equation from the @data@ decl:
85 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
86 u Eq (T b a) u Eq Int -- From C2
87 u Eq (T a a) -- From C3
89 Foo and Bar may have explicit instances for @Eq@, in which case we can
90 just substitute for them. Alternatively, either or both may have
91 their @Eq@ instances given by @deriving@ clauses, in which case they
92 form part of the system of equations.
94 Now all we need do is simplify and solve the equations, iterating to
95 find the least fixpoint. Notice that the order of the arguments can
96 switch around, as here in the recursive calls to T.
98 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
102 Eq (T a b) = {} -- The empty set
105 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
106 u Eq (T b a) u Eq Int -- From C2
107 u Eq (T a a) -- From C3
109 After simplification:
110 = Eq a u Ping b u {} u {} u {}
115 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
116 u Eq (T b a) u Eq Int -- From C2
117 u Eq (T a a) -- From C3
119 After simplification:
124 = Eq a u Ping b u Eq b u Ping a
126 The next iteration gives the same result, so this is the fixpoint. We
127 need to make a canonical form of the RHS to ensure convergence. We do
128 this by simplifying the RHS to a form in which
130 - the classes constrain only tyvars
131 - the list is sorted by tyvar (major key) and then class (minor key)
132 - no duplicates, of course
134 So, here are the synonyms for the ``equation'' structures:
137 type DerivRhs = ThetaType
138 type DerivSoln = DerivRhs
139 type DerivEqn = (SrcSpan, InstOrigin, Name, [TyVar], Class, Type, DerivRhs)
140 -- (span, orig, df, tvs, C, ty, rhs)
141 -- implies a dfun declaration of the form
142 -- df :: forall tvs. rhs => C ty
143 -- The Name is the name for the DFun we'll build
144 -- The tyvars bind all the variables in the RHS
145 -- For family indexes, the tycon is the *family* tycon
146 -- (not the representation tycon)
148 pprDerivEqn :: DerivEqn -> SDoc
149 pprDerivEqn (l, _, n, tvs, c, ty, rhs)
150 = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr ty]
151 <+> equals <+> ppr rhs)
155 [Data decl contexts] A note about contexts on data decls
156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
159 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
161 We will need an instance decl like:
163 instance (Read a, RealFloat a) => Read (Complex a) where
166 The RealFloat in the context is because the read method for Complex is bound
167 to construct a Complex, and doing that requires that the argument type is
170 But this ain't true for Show, Eq, Ord, etc, since they don't construct
171 a Complex; they only take them apart.
173 Our approach: identify the offending classes, and add the data type
174 context to the instance decl. The "offending classes" are
178 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
179 pattern matching against a constructor from a data type with a context
180 gives rise to the constraints for that context -- or at least the thinned
181 version. So now all classes are "offending".
188 newtype T = T Char deriving( C [a] )
190 Notice the free 'a' in the deriving. We have to fill this out to
191 newtype T = T Char deriving( forall a. C [a] )
193 And then translate it to:
194 instance C [a] Char => C [a] T where ...
199 %************************************************************************
201 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
203 %************************************************************************
206 tcDeriving :: [LTyClDecl Name] -- All type constructors
207 -> [LInstDecl Name] -- All instance declarations
208 -> [LDerivDecl Name] -- All stand-alone deriving declarations
209 -> TcM ([InstInfo], -- The generated "instance decls"
210 HsValBinds Name) -- Extra generated top-level bindings
212 tcDeriving tycl_decls inst_decls deriv_decls
213 = recoverM (returnM ([], emptyValBindsOut)) $
214 do { -- Fish the "deriving"-related information out of the TcEnv
215 -- and make the necessary "equations".
216 ; (ordinary_eqns, newtype_inst_info)
217 <- makeDerivEqns tycl_decls inst_decls deriv_decls
219 ; (ordinary_inst_info, deriv_binds)
220 <- extendLocalInstEnv (map iSpec newtype_inst_info) $
221 deriveOrdinaryStuff ordinary_eqns
222 -- Add the newtype-derived instances to the inst env
223 -- before tacking the "ordinary" ones
225 ; let inst_info = newtype_inst_info ++ ordinary_inst_info
227 -- If we are compiling a hs-boot file,
228 -- don't generate any derived bindings
229 ; is_boot <- tcIsHsBoot
231 return (inst_info, emptyValBindsOut)
235 -- Generate the generic to/from functions from each type declaration
236 ; gen_binds <- mkGenericBinds tycl_decls
238 -- Rename these extra bindings, discarding warnings about unused bindings etc
239 -- Type signatures in patterns are used in the generic binds
242 setOptM Opt_PatternSignatures $
244 { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds [])
245 ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
246 ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
248 ; return (rn_deriv `plusHsValBinds` rn_gen) }
252 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
253 (ddump_deriving inst_info rn_binds))
255 ; returnM (inst_info, rn_binds)
258 ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc
259 ddump_deriving inst_infos extra_binds
260 = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
262 -----------------------------------------
263 deriveOrdinaryStuff [] -- Short cut
264 = returnM ([], emptyLHsBinds)
266 deriveOrdinaryStuff eqns
267 = do { -- Take the equation list and solve it, to deliver a list of
268 -- solutions, a.k.a. the contexts for the instance decls
269 -- required for the corresponding equations.
270 overlap_flag <- getOverlapFlag
271 ; inst_specs <- solveDerivEqns overlap_flag eqns
273 -- Generate the InstInfo for each dfun,
274 -- plus any auxiliary bindings it needs
275 ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst inst_specs
277 -- Generate any extra not-one-inst-decl-specific binds,
278 -- notably "con2tag" and/or "tag2con" functions.
279 ; extra_binds <- genTaggeryBinds inst_infos
282 ; returnM (map fst inst_infos,
283 unionManyBags (extra_binds : aux_binds_s))
286 -----------------------------------------
287 mkGenericBinds tycl_decls
288 = do { tcs <- mapM tcLookupTyCon
290 L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls]
291 -- We are only interested in the data type declarations
292 ; return (unionManyBags [ mkTyConGenericBinds tc |
293 tc <- tcs, tyConHasGenerics tc ]) }
294 -- And then only in the ones whose 'has-generics' flag is on
298 %************************************************************************
300 \subsection[TcDeriv-eqns]{Forming the equations}
302 %************************************************************************
304 @makeDerivEqns@ fishes around to find the info about needed derived
305 instances. Complicating factors:
308 We can only derive @Enum@ if the data type is an enumeration
309 type (all nullary data constructors).
312 We can only derive @Ix@ if the data type is an enumeration {\em
313 or} has just one data constructor (e.g., tuples).
316 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
319 Note [Newtype deriving superclasses]
320 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
321 The 'tys' here come from the partial application in the deriving
322 clause. The last arg is the new instance type.
324 We must pass the superclasses; the newtype might be an instance
325 of them in a different way than the representation type
326 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
327 Then the Show instance is not done via isomorphism; it shows
329 The Num instance is derived via isomorphism, but the Show superclass
330 dictionary must the Show instance for Foo, *not* the Show dictionary
331 gotten from the Num dictionary. So we must build a whole new dictionary
332 not just use the Num one. The instance we want is something like:
333 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
336 There may be a coercion needed which we get from the tycon for the newtype
337 when the dict is constructed in TcInstDcls.tcInstDecl2
341 makeDerivEqns :: [LTyClDecl Name]
344 -> TcM ([DerivEqn], -- Ordinary derivings
345 [InstInfo]) -- Special newtype derivings
347 makeDerivEqns tycl_decls inst_decls deriv_decls
348 = do { eqns1 <- mapM deriveTyData $
349 extractTyDataPreds tycl_decls ++
350 [ pd -- traverse assoc data families
351 | L _ (InstDecl _ _ _ ats) <- inst_decls
352 , pd <- extractTyDataPreds ats ]
353 ; eqns2 <- mapM deriveStandalone deriv_decls
354 ; return ([eqn | (Just eqn, _) <- eqns1 ++ eqns2],
355 [inst | (_, Just inst) <- eqns1 ++ eqns2]) }
357 extractTyDataPreds decls =
358 [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
361 ------------------------------------------------------------------
362 deriveStandalone :: LDerivDecl Name -> TcM (Maybe DerivEqn, Maybe InstInfo)
363 -- Standalone deriving declarations
364 -- e.g. deriving instance show a => Show (T a)
365 -- Rather like tcLocalInstDecl
366 deriveStandalone (L loc (DerivDecl deriv_ty))
368 addErrCtxt (standaloneCtxt deriv_ty) $
369 do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
370 ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
371 ; traceTc (text "standalone deriving;"
372 <+> text "tvs:" <+> ppr tvs
373 <+> text "theta:" <+> ppr theta
374 <+> text "tau:" <+> ppr tau)
375 ; (cls, inst_tys) <- checkValidInstHead tau
376 ; let cls_tys = take (length inst_tys - 1) inst_tys
377 inst_ty = last inst_tys
379 ; traceTc (text "standalone deriving;"
380 <+> text "class:" <+> ppr cls
381 <+> text "class types:" <+> ppr cls_tys
382 <+> text "type:" <+> ppr inst_ty)
383 ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
386 ------------------------------------------------------------------
387 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
388 deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name,
389 tcdTyVars = tv_names,
390 tcdTyPats = ty_pats }))
393 do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
394 hs_app = nlHsTyConApp tycon_name hs_ty_args
395 -- We get kinding info for the tyvars by typechecking (T a b)
396 -- Hence forming a tycon application and then dis-assembling it
397 ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
398 ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
399 -- the type variables for the type constructor
400 do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
401 -- The "deriv_pred" is a LHsType to take account of the fact that for
402 -- newtype deriving we allow deriving (forall a. C [a]).
403 ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }
404 deriveTyData (deriv_pred, other_decl)
405 = panic "derivTyData" -- Caller ensures that only TyData can happen
407 ------------------------------------------------------------------
408 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
410 -> TcRn (Maybe DerivEqn, Maybe InstInfo)
411 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
412 | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
413 = do { -- Make tc_app saturated, because that's what the
414 -- mkDataTypeEqn things expect
415 -- It might not be saturated in the standalone deriving case
416 -- derive instance Monad (T a)
417 let extra_tvs = dropList tc_args (tyConTyVars tycon)
418 full_tc_args = tc_args ++ mkTyVarTys extra_tvs
419 full_tvs = tvs ++ extra_tvs
421 ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
423 ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
424 ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
425 ; overlap_flag <- getOverlapFlag
427 -- Be careful to test rep_tc here: in the case of families, we want
428 -- to check the instance tycon, not the family tycon
429 ; if isDataTyCon rep_tc then
430 mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys
431 tycon full_tc_args rep_tc rep_tc_args mtheta
433 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag
435 tycon full_tc_args rep_tc rep_tc_args mtheta }
437 = baleOut (derivingThingErr cls cls_tys tc_app
438 (ptext SLIT("Last argument of the instance must be a type application")))
440 baleOut err = addErrTc err >> returnM (Nothing, Nothing)
443 Auxiliary lookup wrapper which requires that looked up family instances are
444 not type instances. If called with a vanilla tycon, the old type application
448 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
449 tcLookupFamInstExact tycon tys
450 | not (isOpenTyCon tycon)
451 = return (tycon, tys)
453 = do { maybeFamInst <- tcLookupFamInst tycon tys
454 ; case maybeFamInst of
455 Nothing -> famInstNotFound tycon tys False
456 Just famInst@(_, rep_tys)
457 | not variable_only_subst -> famInstNotFound tycon tys True
458 | otherwise -> return famInst
460 tvs = map (Type.getTyVar
461 "TcDeriv.tcLookupFamInstExact")
463 variable_only_subst = all Type.isTyVarTy rep_tys &&
464 sizeVarSet (mkVarSet tvs) == length tvs
465 -- renaming may have no repetitions
470 %************************************************************************
474 %************************************************************************
477 mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
478 -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe DerivRhs
479 -> TcRn (Maybe DerivEqn, Maybe InstInfo)
480 mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
481 tycon tc_args rep_tc rep_tc_args mtheta
482 | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
483 -- NB: pass the *representation* tycon to checkSideConditions
484 = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
487 = ASSERT( null cls_tys )
488 do { loc <- getSrcSpanM
489 ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc
491 ; return (Just eqn, Nothing) }
493 mk_data_eqn :: SrcSpan -> InstOrigin -> [TyVar] -> Class
494 -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe DerivRhs
496 mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
497 | cls `hasKey` typeableClassKey
498 = -- The Typeable class is special in several ways
499 -- data T a b = ... deriving( Typeable )
501 -- instance Typeable2 T where ...
503 -- 1. There are no constraints in the instance
504 -- 2. There are no type variables either
505 -- 3. The actual class we want to generate isn't necessarily
506 -- Typeable; it depends on the arity of the type
507 do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
508 ; dfun_name <- new_dfun_name real_clas tycon
509 ; let theta = fromMaybe [] mtheta
510 ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], theta)
514 = do { dfun_name <- new_dfun_name cls tycon
515 ; let ordinary_constraints
516 = [ mkClassPred cls [arg_ty]
517 | data_con <- tyConDataCons rep_tc,
518 arg_ty <- ASSERT( isVanillaDataCon data_con )
519 dataConInstOrigArgTys data_con rep_tc_args,
520 not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
521 theta = fromMaybe ordinary_constraints mtheta
523 tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
524 stupid_constraints = substTheta tiresome_subst (tyConStupidTheta rep_tc)
525 -- see note [Data decl contexts] above
527 ; return (loc, orig, dfun_name, tvs, cls, mkTyConApp tycon tc_args,
528 stupid_constraints ++ theta)
531 ------------------------------------------------------------------
532 -- Check side conditions that dis-allow derivability for particular classes
533 -- This is *apart* from the newtype-deriving mechanism
535 -- Here we get the representation tycon in case of family instances as it has
536 -- the data constructors - but we need to be careful to fall back to the
537 -- family tycon (with indexes) in error messages.
539 checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
540 checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
542 = Just ty_args_why -- e.g. deriving( Foo s )
544 = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
545 [] -> Just (non_std_why cls)
546 [cond] -> cond (mayDeriveDataTypeable, rep_tc)
547 other -> pprPanic "checkSideConditions" (ppr cls)
549 ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
551 non_std_why cls = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
553 sideConditions :: [(Unique, Condition)]
555 = [ (eqClassKey, cond_std),
556 (ordClassKey, cond_std),
557 (readClassKey, cond_std),
558 (showClassKey, cond_std),
559 (enumClassKey, cond_std `andCond` cond_isEnumeration),
560 (ixClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
561 (boundedClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
562 (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK),
563 (dataClassKey, cond_mayDeriveDataTypeable `andCond` cond_std)
566 type Condition = (Bool, TyCon) -> Maybe SDoc
567 -- Bool is whether or not we are allowed to derive Data and Typeable
568 -- TyCon is the *representation* tycon if the
569 -- data type is an indexed one
572 orCond :: Condition -> Condition -> Condition
575 Nothing -> Nothing -- c1 succeeds
576 Just x -> case c2 tc of -- c1 fails
578 Just y -> Just (x $$ ptext SLIT(" and") $$ y)
581 andCond c1 c2 tc = case c1 tc of
582 Nothing -> c2 tc -- c1 succeeds
583 Just x -> Just x -- c1 fails
585 cond_std :: Condition
587 | any (not . isVanillaDataCon) data_cons = Just existential_why
588 | null data_cons = Just no_cons_why
589 | otherwise = Nothing
591 data_cons = tyConDataCons rep_tc
592 no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
593 ptext SLIT("has no data constructors")
594 existential_why = quotes (pprSourceTyCon rep_tc) <+>
595 ptext SLIT("has non-Haskell-98 constructor(s)")
597 cond_isEnumeration :: Condition
598 cond_isEnumeration (_, rep_tc)
599 | isEnumerationTyCon rep_tc = Nothing
600 | otherwise = Just why
602 why = quotes (pprSourceTyCon rep_tc) <+>
603 ptext SLIT("has non-nullary constructors")
605 cond_isProduct :: Condition
606 cond_isProduct (_, rep_tc)
607 | isProductTyCon rep_tc = Nothing
608 | otherwise = Just why
610 why = quotes (pprSourceTyCon rep_tc) <+>
611 ptext SLIT("has more than one constructor")
613 cond_typeableOK :: Condition
614 -- OK for Typeable class
615 -- Currently: (a) args all of kind *
616 -- (b) 7 or fewer args
617 cond_typeableOK (_, rep_tc)
618 | tyConArity rep_tc > 7 = Just too_many
619 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
621 | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
622 | otherwise = Nothing
624 too_many = quotes (pprSourceTyCon rep_tc) <+>
625 ptext SLIT("has too many arguments")
626 bad_kind = quotes (pprSourceTyCon rep_tc) <+>
627 ptext SLIT("has arguments of kind other than `*'")
628 fam_inst = quotes (pprSourceTyCon rep_tc) <+>
629 ptext SLIT("is a type family")
631 cond_mayDeriveDataTypeable :: Condition
632 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
633 | mayDeriveDataTypeable = Nothing
634 | otherwise = Just why
636 why = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
638 std_class_via_iso clas -- These standard classes can be derived for a newtype
639 -- using the isomorphism trick *even if no -fglasgow-exts*
640 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
641 -- Not Read/Show because they respect the type
642 -- Not Enum, because newtypes are never in Enum
645 new_dfun_name clas tycon -- Just a simple wrapper
646 = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
647 -- The type passed to newDFunName is only used to generate
648 -- a suitable string; hence the empty type arg list
652 %************************************************************************
656 %************************************************************************
659 mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> OverlapFlag -> [Var] -> Class
660 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
662 -> TcRn (Maybe DerivEqn, Maybe InstInfo)
663 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs
664 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
665 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
666 = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
667 ; -- Go ahead and use the isomorphism
668 dfun_name <- new_dfun_name cls tycon
669 ; return (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name,
670 iBinds = NewTypeDerived ntd_info })) }
672 | isNothing mb_std_err -- Use the standard H98 method
673 = do { loc <- getSrcSpanM
674 ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tycon
676 ; return (Just eqn, Nothing) }
678 -- Otherwise we can't derive
679 | newtype_deriving = baleOut cant_derive_err -- Too hard
680 | otherwise = baleOut std_err -- Just complain about being a non-std instance
682 mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
683 std_err = derivingThingErr cls cls_tys tc_app $
684 vcat [fromJust mb_std_err,
685 ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
687 -- Here is the plan for newtype derivings. We see
688 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
689 -- where t is a type,
690 -- ak+1...an is a suffix of a1..an, and are all tyars
691 -- ak+1...an do not occur free in t, nor in the s1..sm
692 -- (C s1 ... sm) is a *partial applications* of class C
693 -- with the last parameter missing
694 -- (T a1 .. ak) matches the kind of C's last argument
695 -- (and hence so does t)
697 -- We generate the instance
698 -- instance forall ({a1..ak} u fvs(s1..sm)).
699 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
700 -- where T a1...ap is the partial application of
701 -- the LHS of the correct kind and p >= k
703 -- NB: the variables below are:
704 -- tc_tvs = [a1, ..., an]
705 -- tyvars_to_keep = [a1, ..., ak]
706 -- rep_ty = t ak .. an
707 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
708 -- tys = [s1, ..., sm]
711 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
712 -- We generate the instance
713 -- instance Monad (ST s) => Monad (T s) where
715 cls_tyvars = classTyVars cls
716 kind = tyVarKind (last cls_tyvars)
717 -- Kind of the thing we want to instance
718 -- e.g. argument kind of Monad, *->*
720 (arg_kinds, _) = splitKindFunTys kind
721 n_args_to_drop = length arg_kinds
722 -- Want to drop 1 arg from (T s a) and (ST s a)
723 -- to get instance Monad (ST s) => Monad (T s)
725 -- Note [newtype representation]
726 -- Need newTyConRhs *not* newTyConRep to get the representation
727 -- type, because the latter looks through all intermediate newtypes
729 -- newtype B = MkB Int
730 -- newtype A = MkA B deriving( Num )
731 -- We want the Num instance of B, *not* the Num instance of Int,
732 -- when making the Num instance of A!
733 rep_ty = newTyConInstRhs rep_tycon rep_tc_args
734 (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
736 n_tyargs_to_keep = tyConArity tycon - n_args_to_drop
737 dropped_tc_args = drop n_tyargs_to_keep tc_args
738 dropped_tvs = tyVarsOfTypes dropped_tc_args
740 n_args_to_keep = length rep_ty_args - n_args_to_drop
741 args_to_drop = drop n_args_to_keep rep_ty_args
742 args_to_keep = take n_args_to_keep rep_ty_args
744 rep_fn' = mkAppTys rep_fn args_to_keep
745 rep_tys = cls_tys ++ [rep_fn']
746 rep_pred = mkClassPred cls rep_tys
747 -- rep_pred is the representation dictionary, from where
748 -- we are gong to get all the methods for the newtype
751 tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)
753 -- Next we figure out what superclass dictionaries to use
754 -- See Note [Newtype deriving superclasses] above
756 inst_tys = cls_tys ++ [tc_app]
757 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
760 -- If there are no tyvars, there's no need
761 -- to abstract over the dictionaries we need
762 -- Example: newtype T = MkT Int deriving( C )
763 -- We get the derived instance
766 -- instance C Int => C T
767 dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs
768 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
769 (dict_args, ntd_info) | null dict_tvs = ([], Just all_preds)
770 | otherwise = (all_preds, Nothing)
772 -- Finally! Here's where we build the dictionary Id
773 mk_inst_spec dfun_name = mkLocalInstance dfun overlap_flag
775 dfun = mkDictFunId dfun_name dict_tvs dict_args cls inst_tys
777 -------------------------------------------------------------------
778 -- Figuring out whether we can only do this newtype-deriving thing
780 right_arity = length cls_tys + 1 == classArity cls
782 -- Never derive Read,Show,Typeable,Data this way
783 non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
784 can_derive_via_isomorphism
785 = not (getUnique cls `elem` non_iso_classes)
786 && right_arity -- Well kinded;
787 -- eg not: newtype T ... deriving( ST )
788 -- because ST needs *2* type params
789 && n_tyargs_to_keep >= 0 -- Type constructor has right kind:
790 -- eg not: newtype T = T Int deriving( Monad )
791 && n_args_to_keep >= 0 -- Rep type has right kind:
792 -- eg not: newtype T a = T Int deriving( Monad )
793 && eta_ok -- Eta reduction works
794 && not (isRecursiveTyCon tycon) -- Does not work for recursive tycons:
795 -- newtype A = MkA [A]
797 -- instance Eq [A] => Eq A !!
798 -- Here's a recursive newtype that's actually OK
799 -- newtype S1 = S1 [T1 ()]
800 -- newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
801 -- It's currently rejected. Oh well.
802 -- In fact we generate an instance decl that has method of form
803 -- meth @ instTy = meth @ repTy
804 -- (no coerce's). We'd need a coerce if we wanted to handle
805 -- recursive newtypes too
807 -- Check that eta reduction is OK
808 eta_ok = (args_to_drop `tcEqTypes` dropped_tc_args)
809 -- (a) the dropped-off args are identical in the source and rep type
810 -- newtype T a b = MkT (S [a] b) deriving( Monad )
811 -- Here the 'b' must be the same in the rep type (S [a] b)
813 && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
814 -- (b) the remaining type args do not mention any of the dropped
817 && (tyVarsOfTypes cls_tys `disjointVarSet` dropped_tvs)
818 -- (c) the type class args do not mention any of the dropped type
821 && all isTyVarTy dropped_tc_args
822 -- (d) in case of newtype family instances, the eta-dropped
823 -- arguments must be type variables (not more complex indexes)
825 cant_derive_err = derivingThingErr cls cls_tys tc_app
826 (vcat [ptext SLIT("even with cunning newtype deriving:"),
827 if isRecursiveTyCon tycon then
828 ptext SLIT("the newtype may be recursive")
830 if not right_arity then
831 quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1")
833 if not (n_tyargs_to_keep >= 0) then
834 ptext SLIT("the type constructor has wrong kind")
835 else if not (n_args_to_keep >= 0) then
836 ptext SLIT("the representation type has wrong kind")
837 else if not eta_ok then
838 ptext SLIT("the eta-reduction property does not hold")
844 %************************************************************************
846 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
848 %************************************************************************
850 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
851 terms, which is the final correct RHS for the corresponding original
855 Each (k,TyVarTy tv) in a solution constrains only a type
859 The (k,TyVarTy tv) pairs in a solution are canonically
860 ordered by sorting on type varible, tv, (major key) and then class, k,
865 solveDerivEqns :: OverlapFlag
867 -> TcM [Instance]-- Solns in same order as eqns.
868 -- This bunch is Absolutely minimal...
870 solveDerivEqns overlap_flag orig_eqns
871 = do { traceTc (text "solveDerivEqns" <+> vcat (map pprDerivEqn orig_eqns))
872 ; iterateDeriv 1 initial_solutions }
874 -- The initial solutions for the equations claim that each
875 -- instance has an empty context; this solution is certainly
876 -- in canonical form.
877 initial_solutions :: [DerivSoln]
878 initial_solutions = [ [] | _ <- orig_eqns ]
880 ------------------------------------------------------------------
881 -- iterateDeriv calculates the next batch of solutions,
882 -- compares it with the current one; finishes if they are the
883 -- same, otherwise recurses with the new solutions.
884 -- It fails if any iteration fails
885 iterateDeriv :: Int -> [DerivSoln] -> TcM [Instance]
886 iterateDeriv n current_solns
887 | n > 20 -- Looks as if we are in an infinite loop
888 -- This can happen if we have -fallow-undecidable-instances
889 -- (See TcSimplify.tcSimplifyDeriv.)
890 = pprPanic "solveDerivEqns: probable loop"
891 (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
894 inst_specs = zipWithEqual "add_solns" mk_inst_spec
895 orig_eqns current_solns
898 -- Extend the inst info from the explicit instance decls
899 -- with the current set of solutions, and simplify each RHS
900 extendLocalInstEnv inst_specs $
901 mappM gen_soln orig_eqns
902 ) `thenM` \ new_solns ->
903 if (current_solns == new_solns) then
906 iterateDeriv (n+1) new_solns
908 ------------------------------------------------------------------
909 gen_soln :: DerivEqn -> TcM [PredType]
910 gen_soln (loc, orig, _, tyvars, clas, inst_ty, deriv_rhs)
912 addErrCtxt (derivInstCtxt clas [inst_ty]) $
913 do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
914 -- checkValidInstance tyvars theta clas [inst_ty]
915 -- Not necessary; see Note [Exotic derived instance contexts]
918 -- Check for a bizarre corner case, when the derived instance decl should
919 -- have form instance C a b => D (T a) where ...
920 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
921 -- of problems; in particular, it's hard to compare solutions for
922 -- equality when finding the fixpoint. So I just rule it out for now.
923 ; let tv_set = mkVarSet tyvars
924 weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
925 ; mapM_ (addErrTc . badDerivedPred) weird_preds
927 -- Claim: the result instance declaration is guaranteed valid
928 -- Hence no need to call:
929 -- checkValidInstance tyvars theta clas inst_tys
930 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
932 ------------------------------------------------------------------
933 mk_inst_spec :: DerivEqn -> DerivSoln -> Instance
934 mk_inst_spec (loc, orig, dfun_name, tyvars, clas, inst_ty, _) theta
935 = mkLocalInstance dfun overlap_flag
937 dfun = mkDictFunId dfun_name tyvars theta clas [inst_ty]
939 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
940 -- Add new locally-defined instances; don't bother to check
941 -- for functional dependency errors -- that'll happen in TcInstDcls
942 extendLocalInstEnv dfuns thing_inside
943 = do { env <- getGblEnv
944 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
945 env' = env { tcg_inst_env = inst_env' }
946 ; setGblEnv env' thing_inside }
950 %************************************************************************
952 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
954 %************************************************************************
956 After all the trouble to figure out the required context for the
957 derived instance declarations, all that's left is to chug along to
958 produce them. They will then be shoved into @tcInstDecls2@, which
959 will do all its usual business.
961 There are lots of possibilities for code to generate. Here are
962 various general remarks.
967 We want derived instances of @Eq@ and @Ord@ (both v common) to be
968 ``you-couldn't-do-better-by-hand'' efficient.
971 Deriving @Show@---also pretty common--- should also be reasonable good code.
974 Deriving for the other classes isn't that common or that big a deal.
981 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
984 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
987 We {\em normally} generate code only for the non-defaulted methods;
988 there are some exceptions for @Eq@ and (especially) @Ord@...
991 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
992 constructor's numeric (@Int#@) tag. These are generated by
993 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
994 these is around is given by @hasCon2TagFun@.
996 The examples under the different sections below will make this
1000 Much less often (really just for deriving @Ix@), we use a
1001 @_tag2con_<tycon>@ function. See the examples.
1004 We use the renamer!!! Reason: we're supposed to be
1005 producing @LHsBinds Name@ for the methods, but that means
1006 producing correctly-uniquified code on the fly. This is entirely
1007 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1008 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1009 the renamer. What a great hack!
1013 -- Generate the InstInfo for the required instance paired with the
1014 -- *representation* tycon for that instance,
1015 -- plus any auxiliary bindings required
1017 -- Representation tycons differ from the tycon in the instance signature in
1018 -- case of instances for indexed families.
1020 genInst :: Instance -> TcM ((InstInfo, TyCon), LHsBinds RdrName)
1022 = do { fix_env <- getFixityEnv
1024 (tyvars,_,clas,[ty]) = instanceHead spec
1025 clas_nm = className clas
1026 (visible_tycon, tyArgs) = tcSplitTyConApp ty
1028 -- In case of a family instance, we need to use the representation
1029 -- tycon (after all, it has the data constructors)
1030 ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
1031 ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
1033 -- Bring the right type variables into
1034 -- scope, and rename the method binds
1035 -- It's a bit yukky that we return *renamed* InstInfo, but
1036 -- *non-renamed* auxiliary bindings
1037 ; (rn_meth_binds, _fvs) <- discardWarnings $
1038 bindLocalNames (map Var.varName tyvars) $
1039 rnMethodBinds clas_nm (\n -> []) [] meth_binds
1041 -- Build the InstInfo
1042 ; return ((InstInfo { iSpec = spec,
1043 iBinds = VanillaInst rn_meth_binds [] }, tycon),
1047 genDerivBinds clas fix_env tycon
1048 | className clas `elem` typeableClassNames
1049 = (gen_Typeable_binds tycon, emptyLHsBinds)
1052 = case assocMaybe gen_list (getUnique clas) of
1053 Just gen_fn -> gen_fn fix_env tycon
1054 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1056 gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))]
1057 gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds))
1058 ,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds))
1059 ,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds))
1060 ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds))
1061 ,(ixClassKey, no_aux_binds (ignore_fix_env gen_Ix_binds))
1062 ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds))
1063 ,(showClassKey, no_aux_binds gen_Show_binds)
1064 ,(readClassKey, no_aux_binds gen_Read_binds)
1065 ,(dataClassKey, gen_Data_binds)
1068 -- no_aux_binds is used for generators that don't
1069 -- need to produce any auxiliary bindings
1070 no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds)
1071 ignore_fix_env f fix_env tc = f tc
1075 %************************************************************************
1077 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1079 %************************************************************************
1084 con2tag_Foo :: Foo ... -> Int#
1085 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1086 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1089 We have a @con2tag@ function for a tycon if:
1092 We're deriving @Eq@ and the tycon has nullary data constructors.
1095 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
1096 (enum type only????)
1099 We have a @tag2con@ function for a tycon if:
1102 We're deriving @Enum@, or @Ix@ (enum type only???)
1105 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
1108 genTaggeryBinds :: [(InstInfo, TyCon)] -> TcM (LHsBinds RdrName)
1109 genTaggeryBinds infos
1110 = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest
1111 ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest
1112 ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) }
1114 all_CTs = [ (fst (simpleInstInfoClsTy info), tc)
1115 | (info, tc) <- infos]
1116 all_tycons = map snd all_CTs
1117 (tycons_of_interest, _) = removeDups compare all_tycons
1119 do_con2tag acc_Names tycon
1120 | isDataTyCon tycon &&
1121 ((we_are_deriving eqClassKey tycon
1122 && any isNullarySrcDataCon (tyConDataCons tycon))
1123 || (we_are_deriving ordClassKey tycon
1124 && not (isProductTyCon tycon))
1125 || (we_are_deriving enumClassKey tycon)
1126 || (we_are_deriving ixClassKey tycon))
1128 = returnM ((con2tag_RDR tycon, tycon, GenCon2Tag)
1133 do_tag2con acc_Names tycon
1134 | isDataTyCon tycon &&
1135 (we_are_deriving enumClassKey tycon ||
1136 we_are_deriving ixClassKey tycon
1137 && isEnumerationTyCon tycon)
1138 = returnM ( (tag2con_RDR tycon, tycon, GenTag2Con)
1139 : (maxtag_RDR tycon, tycon, GenMaxTag)
1144 we_are_deriving clas_key tycon
1145 = is_in_eqns clas_key tycon all_CTs
1147 is_in_eqns clas_key tycon [] = False
1148 is_in_eqns clas_key tycon ((c,t):cts)
1149 = (clas_key == classKey c && tycon == t)
1150 || is_in_eqns clas_key tycon cts
1154 derivingThingErr clas tys ty why
1155 = sep [hsep [ptext SLIT("Can't make a derived instance of"),
1157 nest 2 (parens why)]
1159 pred = mkClassPred clas (tys ++ [ty])
1161 standaloneCtxt :: LHsType Name -> SDoc
1162 standaloneCtxt ty = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty)
1164 derivInstCtxt clas inst_tys
1165 = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1168 = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
1169 ptext SLIT("type variables that are not data type parameters"),
1170 nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
1172 famInstNotFound tycon tys notExact
1173 = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
1175 msg = ptext $ if notExact
1176 then SLIT("No family instance exactly matching")
1177 else SLIT("More than one family instance for")