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
56 %************************************************************************
60 %************************************************************************
64 1. Convert the decls (i.e. data/newtype deriving clauses,
65 plus standalone deriving) to [EarlyDerivSpec]
67 2. Infer the missing contexts for the Left DerivSpecs
69 3. Add the derived bindings, generating InstInfos
72 -- DerivSpec is purely local to this module
73 data DerivSpec = DS { ds_loc :: SrcSpan
74 , ds_orig :: InstOrigin
77 , ds_theta :: ThetaType
81 , ds_tc_args :: [Type]
82 , ds_newtype :: Bool }
83 -- This spec implies a dfun declaration of the form
84 -- df :: forall tvs. theta => C tys
85 -- The Name is the name for the DFun we'll build
86 -- The tyvars bind all the variables in the theta
87 -- For family indexes, the tycon in
88 -- in ds_tys is the *family* tycon
89 -- in ds_tc, ds_tc_args is the *representation* tycon
90 -- For non-family tycons, both are the same
92 -- ds_newtype = True <=> Newtype deriving
93 -- False <=> Vanilla deriving
95 type EarlyDerivSpec = Either DerivSpec DerivSpec
96 -- Left ds => the context for the instance should be inferred
97 -- In this case ds_theta is the list of all the
98 -- constraints needed, such as (Eq [a], Eq a)
99 -- The inference process is to reduce this to a
100 -- simpler form (e.g. Eq a)
102 -- Right ds => the exact context for the instance is supplied
103 -- by the programmer; it is ds_theta
105 pprDerivSpec :: DerivSpec -> SDoc
106 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
107 ds_cls = c, ds_tys = tys, ds_theta = rhs })
108 = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
109 <+> equals <+> ppr rhs)
113 Inferring missing contexts
114 ~~~~~~~~~~~~~~~~~~~~~~~~~~
117 data T a b = C1 (Foo a) (Bar b)
122 [NOTE: See end of these comments for what to do with
123 data (C a, D b) => T a b = ...
126 We want to come up with an instance declaration of the form
128 instance (Ping a, Pong b, ...) => Eq (T a b) where
131 It is pretty easy, albeit tedious, to fill in the code "...". The
132 trick is to figure out what the context for the instance decl is,
133 namely @Ping@, @Pong@ and friends.
135 Let's call the context reqd for the T instance of class C at types
136 (a,b, ...) C (T a b). Thus:
138 Eq (T a b) = (Ping a, Pong b, ...)
140 Now we can get a (recursive) equation from the @data@ decl:
142 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
143 u Eq (T b a) u Eq Int -- From C2
144 u Eq (T a a) -- From C3
146 Foo and Bar may have explicit instances for @Eq@, in which case we can
147 just substitute for them. Alternatively, either or both may have
148 their @Eq@ instances given by @deriving@ clauses, in which case they
149 form part of the system of equations.
151 Now all we need do is simplify and solve the equations, iterating to
152 find the least fixpoint. Notice that the order of the arguments can
153 switch around, as here in the recursive calls to T.
155 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
159 Eq (T a b) = {} -- The empty set
162 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
163 u Eq (T b a) u Eq Int -- From C2
164 u Eq (T a a) -- From C3
166 After simplification:
167 = Eq a u Ping b u {} u {} u {}
172 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
173 u Eq (T b a) u Eq Int -- From C2
174 u Eq (T a a) -- From C3
176 After simplification:
181 = Eq a u Ping b u Eq b u Ping a
183 The next iteration gives the same result, so this is the fixpoint. We
184 need to make a canonical form of the RHS to ensure convergence. We do
185 this by simplifying the RHS to a form in which
187 - the classes constrain only tyvars
188 - the list is sorted by tyvar (major key) and then class (minor key)
189 - no duplicates, of course
191 So, here are the synonyms for the ``equation'' structures:
194 Note [Data decl contexts]
195 ~~~~~~~~~~~~~~~~~~~~~~~~~
198 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
200 We will need an instance decl like:
202 instance (Read a, RealFloat a) => Read (Complex a) where
205 The RealFloat in the context is because the read method for Complex is bound
206 to construct a Complex, and doing that requires that the argument type is
209 But this ain't true for Show, Eq, Ord, etc, since they don't construct
210 a Complex; they only take them apart.
212 Our approach: identify the offending classes, and add the data type
213 context to the instance decl. The "offending classes" are
217 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
218 pattern matching against a constructor from a data type with a context
219 gives rise to the constraints for that context -- or at least the thinned
220 version. So now all classes are "offending".
222 Note [Newtype deriving]
223 ~~~~~~~~~~~~~~~~~~~~~~~
227 newtype T = T Char deriving( C [a] )
229 Notice the free 'a' in the deriving. We have to fill this out to
230 newtype T = T Char deriving( forall a. C [a] )
232 And then translate it to:
233 instance C [a] Char => C [a] T where ...
236 Note [Newtype deriving superclasses]
237 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
238 (See also Trac #1220 for an interesting exchange on newtype
239 deriving and superclasses.)
241 The 'tys' here come from the partial application in the deriving
242 clause. The last arg is the new instance type.
244 We must pass the superclasses; the newtype might be an instance
245 of them in a different way than the representation type
246 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
247 Then the Show instance is not done via isomorphism; it shows
249 The Num instance is derived via isomorphism, but the Show superclass
250 dictionary must the Show instance for Foo, *not* the Show dictionary
251 gotten from the Num dictionary. So we must build a whole new dictionary
252 not just use the Num one. The instance we want is something like:
253 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
256 There may be a coercion needed which we get from the tycon for the newtype
257 when the dict is constructed in TcInstDcls.tcInstDecl2
260 Note [Unused constructors and deriving clauses]
261 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
262 See Trac #3221. Consider
263 data T = T1 | T2 deriving( Show )
264 Are T1 and T2 unused? Well, no: the deriving clause expands to mention
265 both of them. So we gather defs/uses from deriving just like anything else.
267 %************************************************************************
269 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
271 %************************************************************************
274 tcDeriving :: [LTyClDecl Name] -- All type constructors
275 -> [LInstDecl Name] -- All instance declarations
276 -> [LDerivDecl Name] -- All stand-alone deriving declarations
277 -> TcM ([InstInfo Name], -- The generated "instance decls"
278 HsValBinds Name, -- Extra generated top-level bindings
281 tcDeriving tycl_decls inst_decls deriv_decls
282 = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
283 do { -- Fish the "deriving"-related information out of the TcEnv
284 -- And make the necessary "equations".
285 is_boot <- tcIsHsBoot
286 ; traceTc (text "tcDeriving" <+> ppr is_boot)
287 ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
289 ; overlap_flag <- getOverlapFlag
290 ; let (infer_specs, given_specs) = splitEithers early_specs
291 ; insts1 <- mapM (genInst overlap_flag) given_specs
293 ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
294 inferInstanceContexts overlap_flag infer_specs
296 ; insts2 <- mapM (genInst overlap_flag) final_specs
298 -- Generate the generic to/from functions from each type declaration
299 ; gen_binds <- mkGenericBinds is_boot
300 ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
303 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
304 (ddump_deriving inst_info rn_binds))
306 ; return (inst_info, rn_binds, rn_dus) }
308 ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
309 ddump_deriving inst_infos extra_binds
310 = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
312 renameDeriv :: Bool -> LHsBinds RdrName
313 -> [(InstInfo RdrName, DerivAuxBinds)]
314 -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
315 renameDeriv is_boot gen_binds insts
316 | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
317 -- The inst-info bindings will all be empty, but it's easier to
318 -- just use rn_inst_info to change the type appropriately
319 = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
320 ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
323 = discardWarnings $ -- Discard warnings about unused bindings etc
324 do { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns
325 -- are used in the generic binds
326 rnTopBinds (ValBindsIn gen_binds [])
327 ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive
329 -- Generate and rename any extra not-one-inst-decl-specific binds,
330 -- notably "con2tag" and/or "tag2con" functions.
331 -- Bring those names into scope before renaming the instances themselves
332 ; loc <- getSrcSpanM -- Generic loc for shared bindings
333 ; let aux_binds = listToBag $ map (genAuxBind loc) $
334 rm_dups [] $ concat deriv_aux_binds
335 ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds [])
336 ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs)
338 ; bindLocalNames aux_names $
339 do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
340 ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
341 ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
342 dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
345 (inst_infos, deriv_aux_binds) = unzip insts
347 -- Remove duplicate requests for auxilliary bindings
349 rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
350 | otherwise = rm_dups (b:acc) bs
353 rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
354 = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
356 rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
357 = -- Bring the right type variables into
358 -- scope (yuk), and rename the method binds
360 bindLocalNames (map Var.varName tyvars) $
361 do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
362 ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }, fvs) }
364 (tyvars,_,clas,_) = instanceHead inst
365 clas_nm = className clas
367 -----------------------------------------
368 mkGenericBinds :: Bool -> TcM (LHsBinds RdrName)
369 mkGenericBinds is_boot
373 = do { gbl_env <- getGblEnv
374 ; let tcs = typeEnvTyCons (tcg_type_env gbl_env)
375 ; return (unionManyBags [ mkTyConGenericBinds tc |
376 tc <- tcs, tyConHasGenerics tc ]) }
377 -- We are only interested in the data type declarations,
378 -- and then only in the ones whose 'has-generics' flag is on
379 -- The predicate tyConHasGenerics finds both of these
383 %************************************************************************
385 From HsSyn to DerivSpec
387 %************************************************************************
389 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
392 makeDerivSpecs :: Bool
396 -> TcM [EarlyDerivSpec]
398 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
399 | is_boot -- No 'deriving' at all in hs-boot files
400 = do { mapM_ add_deriv_err deriv_locs
403 = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
404 ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
405 ; return (eqns1 ++ eqns2) }
407 extractTyDataPreds decls
408 = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
410 all_tydata :: [(LHsType Name, LTyClDecl Name)]
411 -- Derived predicate paired with its data type declaration
412 all_tydata = extractTyDataPreds tycl_decls ++
413 [ pd -- Traverse assoc data families
414 | L _ (InstDecl _ _ _ ats) <- inst_decls
415 , pd <- extractTyDataPreds ats ]
417 deriv_locs = map (getLoc . snd) all_tydata
418 ++ map getLoc deriv_decls
420 add_deriv_err loc = setSrcSpan loc $
421 addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
422 2 (ptext (sLit "Use an instance declaration instead")))
424 ------------------------------------------------------------------
425 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
426 -- Standalone deriving declarations
427 -- e.g. deriving instance Show a => Show (T a)
428 -- Rather like tcLocalInstDecl
429 deriveStandalone (L loc (DerivDecl deriv_ty))
431 addErrCtxt (standaloneCtxt deriv_ty) $
432 do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
433 ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
434 ; traceTc (text "standalone deriving;"
435 <+> text "tvs:" <+> ppr tvs
436 <+> text "theta:" <+> ppr theta
437 <+> text "tau:" <+> ppr tau)
438 ; (cls, inst_tys) <- checkValidInstHead tau
439 ; checkValidInstance tvs theta cls inst_tys
440 -- C.f. TcInstDcls.tcLocalInstDecl1
442 ; let cls_tys = take (length inst_tys - 1) inst_tys
443 inst_ty = last inst_tys
444 ; traceTc (text "standalone deriving;"
445 <+> text "class:" <+> ppr cls
446 <+> text "class types:" <+> ppr cls_tys
447 <+> text "type:" <+> ppr inst_ty)
448 ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
451 ------------------------------------------------------------------
452 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
453 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
454 tcdTyVars = tv_names,
455 tcdTyPats = ty_pats }))
456 = setSrcSpan loc $ -- Use the location of the 'deriving' item
458 do { (tvs, tc, tc_args) <- get_lhs ty_pats
459 ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
460 -- the type variables for the type constructor
462 do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
463 -- The "deriv_pred" is a LHsType to take account of the fact that for
464 -- newtype deriving we allow deriving (forall a. C [a]).
466 -- Given data T a b c = ... deriving( C d ),
467 -- we want to drop type variables from T so that (C d (T a)) is well-kinded
468 ; let cls_tyvars = classTyVars cls
469 kind = tyVarKind (last cls_tyvars)
470 (arg_kinds, _) = splitKindFunTys kind
471 n_args_to_drop = length arg_kinds
472 n_args_to_keep = tyConArity tc - n_args_to_drop
473 args_to_drop = drop n_args_to_keep tc_args
474 inst_ty = mkTyConApp tc (take n_args_to_keep tc_args)
475 inst_ty_kind = typeKind inst_ty
476 dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
477 univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
478 `minusVarSet` dropped_tvs
480 -- Check that the result really is well-kinded
481 ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
482 (derivingKindErr tc cls cls_tys kind)
484 ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a)
485 tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
486 (derivingEtaErr cls cls_tys inst_ty)
488 -- (a) The data type can be eta-reduced; eg reject:
489 -- data instance T a a = ... deriving( Monad )
490 -- (b) The type class args do not mention any of the dropped type
492 -- newtype T a s = ... deriving( ST s )
494 -- Type families can't be partially applied
495 -- e.g. newtype instance T Int a = MkT [a] deriving( Monad )
496 -- Note [Deriving, type families, and partial applications]
497 ; checkTc (not (isOpenTyCon tc) || n_args_to_drop == 0)
498 (typeFamilyPapErr tc cls cls_tys inst_ty)
500 ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
502 -- Tiresomely we must figure out the "lhs", which is awkward for type families
503 -- E.g. data T a b = .. deriving( Eq )
504 -- Here, the lhs is (T a b)
505 -- data instance TF Int b = ... deriving( Eq )
506 -- Here, the lhs is (TF Int b)
507 -- But if we just look up the tycon_name, we get is the *family*
508 -- tycon, but not pattern types -- they are in the *rep* tycon.
509 get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
510 ; let tvs = tyConTyVars tc
511 ; return (tvs, tc, mkTyVarTys tvs) }
512 get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
513 ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
514 ; let (tc, tc_args) = tcSplitTyConApp tc_app
515 ; return (tvs, tc, tc_args) }
518 = panic "derivTyData" -- Caller ensures that only TyData can happen
521 Note [Deriving, type families, and partial applications]
522 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
523 When there are no type families, it's quite easy:
525 newtype S a = MkS [a]
526 -- :CoS :: S ~ [] -- Eta-reduced
528 instance Eq [a] => Eq (S a) -- by coercion sym (Eq (coMkS a)) : Eq [a] ~ Eq (S a)
529 instance Monad [] => Monad S -- by coercion sym (Monad coMkS) : Monad [] ~ Monad S
531 When type familes are involved it's trickier:
534 newtype instance T Int a = MkT [a] deriving( Eq, Monad )
535 -- :RT is the representation type for (T Int a)
536 -- :CoF:R1T a :: T Int a ~ :RT a -- Not eta reduced
537 -- :Co:R1T :: :RT ~ [] -- Eta-reduced
539 instance Eq [a] => Eq (T Int a) -- easy by coercion
540 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
542 The "???" bit is that we don't build the :CoF thing in eta-reduced form
543 Henc the current typeFamilyPapErr, even though the instance makes sense.
544 After all, we can write it out
545 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
550 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
551 -> Maybe ThetaType -- Just => context supplied (standalone deriving)
552 -- Nothing => context inferred (deriving on data decl)
553 -> TcRn EarlyDerivSpec
554 -- Make the EarlyDerivSpec for an instance
555 -- forall tvs. theta => cls (tys ++ [ty])
556 -- where the 'theta' is optional (that's the Maybe part)
557 -- Assumes that this declaration is well-kinded
559 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
560 | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
561 , isAlgTyCon tycon -- Check for functions, primitive types etc
562 = do { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
563 -- Be careful to test rep_tc here: in the case of families,
564 -- we want to check the instance tycon, not the family tycon
566 -- For standalone deriving (mtheta /= Nothing),
567 -- check that all the data constructors are in scope.
568 -- No need for this when deriving Typeable, becuase we don't need
569 -- the constructors for that.
570 ; rdr_env <- getGlobalRdrEnv
571 ; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc)
572 not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
573 ; checkTc (isNothing mtheta ||
574 not hidden_data_cons ||
575 className cls `elem` typeableClassNames)
576 (derivingHiddenErr tycon)
579 ; if isDataTyCon rep_tc then
580 mkDataTypeEqn orig dflags tvs cls cls_tys
581 tycon tc_args rep_tc rep_tc_args mtheta
583 mkNewTypeEqn orig dflags tvs cls cls_tys
584 tycon tc_args rep_tc rep_tc_args mtheta }
586 = failWithTc (derivingThingErr cls cls_tys tc_app
587 (ptext (sLit "The last argument of the instance must be a data or newtype application")))
590 Note [Looking up family instances for deriving]
591 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
592 tcLookupFamInstExact is an auxiliary lookup wrapper which requires
593 that looked-up family instances exist. If called with a vanilla
594 tycon, the old type application is simply returned.
597 data instance F () = ... deriving Eq
598 data instance F () = ... deriving Eq
599 then tcLookupFamInstExact will be confused by the two matches;
600 but that can't happen because tcInstDecls1 doesn't call tcDeriving
601 if there are any overlaps.
603 There are two other things that might go wrong with the lookup.
604 First, we might see a standalone deriving clause
606 when there is no data instance F () in scope.
608 Note that it's OK to have
609 data instance F [a] = ...
610 deriving Eq (F [(a,b)])
611 where the match is not exact; the same holds for ordinary data types
612 with standalone deriving declrations.
615 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
616 tcLookupFamInstExact tycon tys
617 | not (isOpenTyCon tycon)
618 = return (tycon, tys)
620 = do { maybeFamInst <- tcLookupFamInst tycon tys
621 ; case maybeFamInst of
622 Nothing -> famInstNotFound tycon tys
623 Just famInst -> return famInst
626 famInstNotFound :: TyCon -> [Type] -> TcM a
627 famInstNotFound tycon tys
628 = failWithTc (ptext (sLit "No family instance for")
629 <+> quotes (pprTypeApp tycon tys))
633 %************************************************************************
637 %************************************************************************
640 mkDataTypeEqn :: InstOrigin
642 -> [Var] -- Universally quantified type variables in the instance
643 -> Class -- Class for which we need to derive an instance
644 -> [Type] -- Other parameters to the class except the last
645 -> TyCon -- Type constructor for which the instance is requested (last parameter to the type class)
646 -> [Type] -- Parameters to the type constructor
647 -> TyCon -- rep of the above (for type families)
648 -> [Type] -- rep of the above
649 -> Maybe ThetaType -- Context of the instance, for standalone deriving
650 -> TcRn EarlyDerivSpec -- Return 'Nothing' if error
652 mkDataTypeEqn orig dflags tvs cls cls_tys
653 tycon tc_args rep_tc rep_tc_args mtheta
654 = case checkSideConditions dflags cls cls_tys rep_tc of
655 -- NB: pass the *representation* tycon to checkSideConditions
656 CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
657 NonDerivableClass -> bale_out (nonStdErr cls)
658 DerivableClassError msg -> bale_out msg
660 bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg)
662 mk_data_eqn, mk_typeable_eqn
663 :: InstOrigin -> [TyVar] -> Class
664 -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
665 -> TcM EarlyDerivSpec
666 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
667 | getName cls `elem` typeableClassNames
668 = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
671 = do { dfun_name <- new_dfun_name cls tycon
673 ; let inst_tys = [mkTyConApp tycon tc_args]
674 inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
675 spec = DS { ds_loc = loc, ds_orig = orig
676 , ds_name = dfun_name, ds_tvs = tvs
677 , ds_cls = cls, ds_tys = inst_tys
678 , ds_tc = rep_tc, ds_tc_args = rep_tc_args
679 , ds_theta = mtheta `orElse` inferred_constraints
680 , ds_newtype = False }
682 ; return (if isJust mtheta then Right spec -- Specified context
683 else Left spec) } -- Infer context
685 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
686 -- The Typeable class is special in several ways
687 -- data T a b = ... deriving( Typeable )
689 -- instance Typeable2 T where ...
691 -- 1. There are no constraints in the instance
692 -- 2. There are no type variables either
693 -- 3. The actual class we want to generate isn't necessarily
694 -- Typeable; it depends on the arity of the type
695 | isNothing mtheta -- deriving on a data type decl
696 = do { checkTc (cls `hasKey` typeableClassKey)
697 (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
698 ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
699 ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
701 | otherwise -- standaone deriving
702 = do { checkTc (null tc_args)
703 (ptext (sLit "Derived typeable instance must be of form (Typeable")
704 <> int (tyConArity tycon) <+> ppr tycon <> rparen)
705 ; dfun_name <- new_dfun_name cls tycon
708 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
709 , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
710 , ds_tc = rep_tc, ds_tc_args = rep_tc_args
711 , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
714 inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
715 -- Generate a sufficiently large set of constraints that typechecking the
716 -- generated method definitions should succeed. This set will be simplified
717 -- before being used in the instance declaration
718 inferConstraints tvs cls inst_tys rep_tc rep_tc_args
719 = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
720 stupid_constraints ++ extra_constraints
721 ++ sc_constraints ++ con_arg_constraints
723 -- Constraints arising from the arguments of each constructor
725 = [ mkClassPred cls [arg_ty]
726 | data_con <- tyConDataCons rep_tc,
727 arg_ty <- ASSERT( isVanillaDataCon data_con )
728 get_constrained_tys $
729 dataConInstOrigArgTys data_con all_rep_tc_args,
730 not (isUnLiftedType arg_ty) ]
731 -- No constraints for unlifted types
732 -- Where they are legal we generate specilised function calls
734 -- For functor-like classes, two things are different
735 -- (a) We recurse over argument types to generate constraints
736 -- See Functor examples in TcGenDeriv
737 -- (b) The rep_tc_args will be one short
738 is_functor_like = getUnique cls `elem` functorLikeClassKeys
740 get_constrained_tys :: [Type] -> [Type]
741 get_constrained_tys tys
742 | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
745 rep_tc_tvs = tyConTyVars rep_tc
746 last_tv = last rep_tc_tvs
747 all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
748 | otherwise = rep_tc_args
750 -- Constraints arising from superclasses
751 -- See Note [Superclasses of derived instance]
752 sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
755 -- Stupid constraints
756 stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
757 subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
760 -- The Data class (only) requires that for
761 -- instance (...) => Data (T a b)
762 -- then (Data a, Data b) are among the (...) constraints
763 -- Reason: that's what you need to typecheck the method
764 -- dataCast1 f = gcast1 f
766 | cls `hasKey` dataClassKey = [mkClassPred cls [mkTyVarTy tv] | tv <- tvs]
769 ------------------------------------------------------------------
770 -- Check side conditions that dis-allow derivability for particular classes
771 -- This is *apart* from the newtype-deriving mechanism
773 -- Here we get the representation tycon in case of family instances as it has
774 -- the data constructors - but we need to be careful to fall back to the
775 -- family tycon (with indexes) in error messages.
777 data DerivStatus = CanDerive
778 | DerivableClassError SDoc -- Standard class, but can't do it
779 | NonDerivableClass -- Non-standard class
781 checkSideConditions :: DynFlags -> Class -> [TcType] -> TyCon -> DerivStatus
782 checkSideConditions dflags cls cls_tys rep_tc
783 | Just cond <- sideConditions cls
784 = case (cond (dflags, rep_tc)) of
785 Just err -> DerivableClassError err -- Class-specific error
786 Nothing | null cls_tys -> CanDerive
787 | otherwise -> DerivableClassError ty_args_why -- e.g. deriving( Eq s )
788 | otherwise = NonDerivableClass -- Not a standard class
790 ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
792 nonStdErr :: Class -> SDoc
793 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
795 sideConditions :: Class -> Maybe Condition
797 | cls_key == eqClassKey = Just cond_std
798 | cls_key == ordClassKey = Just cond_std
799 | cls_key == showClassKey = Just cond_std
800 | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
801 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
802 | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
803 | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
804 | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond`
805 cond_std `andCond` cond_noUnliftedArgs)
806 | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond`
807 cond_functorOK True) -- NB: no cond_std!
808 | cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond`
809 cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
810 | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
811 cond_functorOK False)
812 | getName cls `elem` typeableClassNames = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK)
813 | otherwise = Nothing
815 cls_key = getUnique cls
817 type Condition = (DynFlags, TyCon) -> Maybe SDoc
818 -- first Bool is whether or not we are allowed to derive Data and Typeable
819 -- second Bool is whether or not we are allowed to derive Functor
820 -- TyCon is the *representation* tycon if the
821 -- data type is an indexed one
824 orCond :: Condition -> Condition -> Condition
827 Nothing -> Nothing -- c1 succeeds
828 Just x -> case c2 tc of -- c1 fails
830 Just y -> Just (x $$ ptext (sLit " and") $$ y)
833 andCond :: Condition -> Condition -> Condition
834 andCond c1 c2 tc = case c1 tc of
835 Nothing -> c2 tc -- c1 succeeds
836 Just x -> Just x -- c1 fails
838 cond_std :: Condition
840 | null data_cons = Just no_cons_why
841 | not (null con_whys) = Just (vcat con_whys)
842 | otherwise = Nothing
844 data_cons = tyConDataCons rep_tc
845 no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
846 ptext (sLit "has no data constructors")
848 con_whys = mapCatMaybes check_con data_cons
850 check_con :: DataCon -> Maybe SDoc
852 | isVanillaDataCon con
853 , all isTauTy (dataConOrigArgTys con) = Nothing
854 | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
856 cond_enumOrProduct :: Condition
857 cond_enumOrProduct = cond_isEnumeration `orCond`
858 (cond_isProduct `andCond` cond_noUnliftedArgs)
860 cond_noUnliftedArgs :: Condition
861 -- For some classes (eg Eq, Ord) we allow unlifted arg types
862 -- by generating specilaised code. For others (eg Data) we don't.
863 cond_noUnliftedArgs (_, tc)
864 | null bad_cons = Nothing
865 | otherwise = Just why
867 bad_cons = [ con | con <- tyConDataCons tc
868 , any isUnLiftedType (dataConOrigArgTys con) ]
869 why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
871 cond_isEnumeration :: Condition
872 cond_isEnumeration (_, rep_tc)
873 | isEnumerationTyCon rep_tc = Nothing
874 | otherwise = Just why
876 why = quotes (pprSourceTyCon rep_tc) <+>
877 ptext (sLit "has non-nullary constructors")
879 cond_isProduct :: Condition
880 cond_isProduct (_, rep_tc)
881 | isProductTyCon rep_tc = Nothing
882 | otherwise = Just why
884 why = quotes (pprSourceTyCon rep_tc) <+>
885 ptext (sLit "has more than one constructor")
887 cond_typeableOK :: Condition
888 -- OK for Typeable class
889 -- Currently: (a) args all of kind *
890 -- (b) 7 or fewer args
891 cond_typeableOK (_, rep_tc)
892 | tyConArity rep_tc > 7 = Just too_many
893 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
895 | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
896 | otherwise = Nothing
898 too_many = quotes (pprSourceTyCon rep_tc) <+>
899 ptext (sLit "has too many arguments")
900 bad_kind = quotes (pprSourceTyCon rep_tc) <+>
901 ptext (sLit "has arguments of kind other than `*'")
902 fam_inst = quotes (pprSourceTyCon rep_tc) <+>
903 ptext (sLit "is a type family")
906 functorLikeClassKeys :: [Unique]
907 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
909 cond_functorOK :: Bool -> Condition
910 -- OK for Functor class
911 -- Currently: (a) at least one argument
912 -- (b) don't use argument contravariantly
913 -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
914 -- (d) optionally: don't use function types
915 cond_functorOK allowFunctions (dflags, rep_tc)
916 | not (dopt Opt_DeriveFunctor dflags)
917 = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
919 = msum (map check_con data_cons) -- msum picks the first 'Just', if any
921 data_cons = tyConDataCons rep_tc
922 check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
924 check_vanilla :: DataCon -> Maybe SDoc
925 check_vanilla con | isVanillaDataCon con = Nothing
926 | otherwise = Just (badCon con existential)
928 ft_check :: DataCon -> FFoldType (Maybe SDoc)
929 ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
930 , ft_co_var = Just (badCon con covariant)
931 , ft_fun = \x y -> if allowFunctions then x `mplus` y
932 else Just (badCon con functions)
933 , ft_tup = \_ xs -> msum xs
934 , ft_ty_app = \_ x -> x
935 , ft_bad_app = Just (badCon con wrong_arg)
936 , ft_forall = \_ x -> x }
938 existential = ptext (sLit "has existential arguments")
939 covariant = ptext (sLit "uses the type variable in a function argument")
940 functions = ptext (sLit "contains function types")
941 wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
943 checkFlag :: DynFlag -> Condition
944 checkFlag flag (dflags, _)
945 | dopt flag dflags = Nothing
946 | otherwise = Just why
948 why = ptext (sLit "You need -X") <> text flag_str
949 <+> ptext (sLit "to derive an instance for this class")
950 flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
952 other -> pprPanic "checkFlag" (ppr other)
954 std_class_via_iso :: Class -> Bool
955 std_class_via_iso clas -- These standard classes can be derived for a newtype
956 -- using the isomorphism trick *even if no -fglasgow-exts*
957 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
958 -- Not Read/Show because they respect the type
959 -- Not Enum, because newtypes are never in Enum
962 new_dfun_name :: Class -> TyCon -> TcM Name
963 new_dfun_name clas tycon -- Just a simple wrapper
964 = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon
965 ; newDFunName clas [mkTyConApp tycon []] loc }
966 -- The type passed to newDFunName is only used to generate
967 -- a suitable string; hence the empty type arg list
969 badCon :: DataCon -> SDoc -> SDoc
970 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
973 Note [Superclasses of derived instance]
974 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
975 In general, a derived instance decl needs the superclasses of the derived
976 class too. So if we have
977 data T a = ...deriving( Ord )
978 then the initial context for Ord (T a) should include Eq (T a). Often this is
979 redundant; we'll also generate an Ord constraint for each constructor argument,
980 and that will probably generate enough constraints to make the Eq (T a) constraint
981 be satisfied too. But not always; consider:
987 data T a = MkT (S a) deriving( Ord )
988 instance Num a => Eq (T a)
990 The derived instance for (Ord (T a)) must have a (Num a) constraint!
992 data T a = MkT deriving( Data, Typeable )
993 Here there *is* no argument field, but we must nevertheless generate
994 a context for the Data instances:
995 instance Typable a => Data (T a) where ...
998 %************************************************************************
1002 %************************************************************************
1005 mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class
1006 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1008 -> TcRn EarlyDerivSpec
1009 mkNewTypeEqn orig dflags tvs
1010 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1011 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1012 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1013 = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
1014 ; dfun_name <- new_dfun_name cls tycon
1015 ; loc <- getSrcSpanM
1016 ; let spec = DS { ds_loc = loc, ds_orig = orig
1017 , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
1018 , ds_cls = cls, ds_tys = inst_tys
1019 , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1020 , ds_theta = mtheta `orElse` all_preds
1021 , ds_newtype = True }
1022 ; return (if isJust mtheta then Right spec
1026 = case check_conditions of
1027 CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1028 -- Use the standard H98 method
1029 DerivableClassError msg -> bale_out msg -- Error with standard class
1030 NonDerivableClass -- Must use newtype deriving
1031 | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
1032 | otherwise -> bale_out non_std_err -- Try newtype deriving!
1034 newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
1035 check_conditions = checkSideConditions dflags cls cls_tys rep_tycon
1036 bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
1038 non_std_err = nonStdErr cls $$
1039 ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1041 -- Here is the plan for newtype derivings. We see
1042 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1043 -- where t is a type,
1044 -- ak+1...an is a suffix of a1..an, and are all tyars
1045 -- ak+1...an do not occur free in t, nor in the s1..sm
1046 -- (C s1 ... sm) is a *partial applications* of class C
1047 -- with the last parameter missing
1048 -- (T a1 .. ak) matches the kind of C's last argument
1049 -- (and hence so does t)
1050 -- The latter kind-check has been done by deriveTyData already,
1051 -- and tc_args are already trimmed
1053 -- We generate the instance
1054 -- instance forall ({a1..ak} u fvs(s1..sm)).
1055 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
1056 -- where T a1...ap is the partial application of
1057 -- the LHS of the correct kind and p >= k
1059 -- NB: the variables below are:
1060 -- tc_tvs = [a1, ..., an]
1061 -- tyvars_to_keep = [a1, ..., ak]
1062 -- rep_ty = t ak .. an
1063 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
1064 -- tys = [s1, ..., sm]
1067 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1068 -- We generate the instance
1069 -- instance Monad (ST s) => Monad (T s) where
1071 nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1072 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1073 -- eta-reduces the representation type, so we know that
1075 -- That's convenient here, because we may have to apply
1076 -- it to fewer than its original complement of arguments
1078 -- Note [Newtype representation]
1079 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1080 -- Need newTyConRhs (*not* a recursive representation finder)
1081 -- to get the representation type. For example
1082 -- newtype B = MkB Int
1083 -- newtype A = MkA B deriving( Num )
1084 -- We want the Num instance of B, *not* the Num instance of Int,
1085 -- when making the Num instance of A!
1086 rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1087 rep_tys = cls_tys ++ [rep_inst_ty]
1088 rep_pred = mkClassPred cls rep_tys
1089 -- rep_pred is the representation dictionary, from where
1090 -- we are gong to get all the methods for the newtype
1094 -- Next we figure out what superclass dictionaries to use
1095 -- See Note [Newtype deriving superclasses] above
1097 cls_tyvars = classTyVars cls
1098 dfun_tvs = tyVarsOfTypes inst_tys
1099 inst_ty = mkTyConApp tycon tc_args
1100 inst_tys = cls_tys ++ [inst_ty]
1101 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1104 -- If there are no tyvars, there's no need
1105 -- to abstract over the dictionaries we need
1106 -- Example: newtype T = MkT Int deriving( C )
1107 -- We get the derived instance
1110 -- instance C Int => C T
1111 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
1113 -------------------------------------------------------------------
1114 -- Figuring out whether we can only do this newtype-deriving thing
1116 can_derive_via_isomorphism
1117 = not (non_iso_class cls)
1121 -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
1123 -- Never derive Read,Show,Typeable,Data by isomorphism
1124 non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
1127 arity_ok = length cls_tys + 1 == classArity cls
1128 -- Well kinded; eg not: newtype T ... deriving( ST )
1129 -- because ST needs *2* type params
1131 -- Check that eta reduction is OK
1132 eta_ok = nt_eta_arity <= length rep_tc_args
1133 -- The newtype can be eta-reduced to match the number
1134 -- of type argument actually supplied
1135 -- newtype T a b = MkT (S [a] b) deriving( Monad )
1136 -- Here the 'b' must be the same in the rep type (S [a] b)
1137 -- And the [a] must not mention 'b'. That's all handled
1140 ats_ok = null (classATs cls)
1141 -- No associated types for the class, because we don't
1142 -- currently generate type 'instance' decls; and cannot do
1143 -- so for 'data' instance decls
1146 = vcat [ ptext (sLit "even with cunning newtype deriving:")
1147 , if arity_ok then empty else arity_msg
1148 , if eta_ok then empty else eta_msg
1149 , if ats_ok then empty else ats_msg ]
1150 arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1151 eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
1152 ats_msg = ptext (sLit "the class has associated types")
1155 Note [Recursive newtypes]
1156 ~~~~~~~~~~~~~~~~~~~~~~~~~
1157 Newtype deriving works fine, even if the newtype is recursive.
1158 e.g. newtype S1 = S1 [T1 ()]
1159 newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1160 Remember, too, that type families are curretly (conservatively) given
1161 a recursive flag, so this also allows newtype deriving to work
1164 We used to exclude recursive types, because we had a rather simple
1165 minded way of generating the instance decl:
1167 instance Eq [A] => Eq A -- Makes typechecker loop!
1168 But now we require a simple context, so it's ok.
1171 %************************************************************************
1173 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1175 %************************************************************************
1177 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1178 terms, which is the final correct RHS for the corresponding original
1182 Each (k,TyVarTy tv) in a solution constrains only a type
1186 The (k,TyVarTy tv) pairs in a solution are canonically
1187 ordered by sorting on type varible, tv, (major key) and then class, k,
1192 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1194 inferInstanceContexts _ [] = return []
1196 inferInstanceContexts oflag infer_specs
1197 = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
1198 ; iterate_deriv 1 initial_solutions }
1200 ------------------------------------------------------------------
1201 -- The initial solutions for the equations claim that each
1202 -- instance has an empty context; this solution is certainly
1203 -- in canonical form.
1204 initial_solutions :: [ThetaType]
1205 initial_solutions = [ [] | _ <- infer_specs ]
1207 ------------------------------------------------------------------
1208 -- iterate_deriv calculates the next batch of solutions,
1209 -- compares it with the current one; finishes if they are the
1210 -- same, otherwise recurses with the new solutions.
1211 -- It fails if any iteration fails
1212 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1213 iterate_deriv n current_solns
1214 | n > 20 -- Looks as if we are in an infinite loop
1215 -- This can happen if we have -XUndecidableInstances
1216 -- (See TcSimplify.tcSimplifyDeriv.)
1217 = pprPanic "solveDerivEqns: probable loop"
1218 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1220 = do { -- Extend the inst info from the explicit instance decls
1221 -- with the current set of solutions, and simplify each RHS
1222 let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1223 current_solns infer_specs
1224 ; new_solns <- checkNoErrs $
1225 extendLocalInstEnv inst_specs $
1226 mapM gen_soln infer_specs
1228 ; if (current_solns == new_solns) then
1229 return [ spec { ds_theta = soln }
1230 | (spec, soln) <- zip infer_specs current_solns ]
1232 iterate_deriv (n+1) new_solns }
1234 ------------------------------------------------------------------
1235 gen_soln :: DerivSpec -> TcM [PredType]
1236 gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1237 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1239 addErrCtxt (derivInstCtxt clas inst_tys) $
1240 do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
1241 -- checkValidInstance tyvars theta clas inst_tys
1242 -- Not necessary; see Note [Exotic derived instance contexts]
1245 -- Check for a bizarre corner case, when the derived instance decl should
1246 -- have form instance C a b => D (T a) where ...
1247 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1248 -- of problems; in particular, it's hard to compare solutions for
1249 -- equality when finding the fixpoint. So I just rule it out for now.
1250 ; let tv_set = mkVarSet tyvars
1251 weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
1252 ; mapM_ (addErrTc . badDerivedPred) weird_preds
1254 -- Claim: the result instance declaration is guaranteed valid
1255 -- Hence no need to call:
1256 -- checkValidInstance tyvars theta clas inst_tys
1257 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
1259 ------------------------------------------------------------------
1260 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1261 mkInstance overlap_flag theta
1262 (DS { ds_name = dfun_name
1263 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1264 = mkLocalInstance dfun overlap_flag
1266 dfun = mkDictFunId dfun_name tyvars theta clas tys
1269 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1270 -- Add new locally-defined instances; don't bother to check
1271 -- for functional dependency errors -- that'll happen in TcInstDcls
1272 extendLocalInstEnv dfuns thing_inside
1273 = do { env <- getGblEnv
1274 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1275 env' = env { tcg_inst_env = inst_env' }
1276 ; setGblEnv env' thing_inside }
1280 %************************************************************************
1282 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1284 %************************************************************************
1286 After all the trouble to figure out the required context for the
1287 derived instance declarations, all that's left is to chug along to
1288 produce them. They will then be shoved into @tcInstDecls2@, which
1289 will do all its usual business.
1291 There are lots of possibilities for code to generate. Here are
1292 various general remarks.
1297 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1298 ``you-couldn't-do-better-by-hand'' efficient.
1301 Deriving @Show@---also pretty common--- should also be reasonable good code.
1304 Deriving for the other classes isn't that common or that big a deal.
1311 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1314 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1317 We {\em normally} generate code only for the non-defaulted methods;
1318 there are some exceptions for @Eq@ and (especially) @Ord@...
1321 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1322 constructor's numeric (@Int#@) tag. These are generated by
1323 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1324 these is around is given by @hasCon2TagFun@.
1326 The examples under the different sections below will make this
1330 Much less often (really just for deriving @Ix@), we use a
1331 @_tag2con_<tycon>@ function. See the examples.
1334 We use the renamer!!! Reason: we're supposed to be
1335 producing @LHsBinds Name@ for the methods, but that means
1336 producing correctly-uniquified code on the fly. This is entirely
1337 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1338 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1339 the renamer. What a great hack!
1343 -- Generate the InstInfo for the required instance paired with the
1344 -- *representation* tycon for that instance,
1345 -- plus any auxiliary bindings required
1347 -- Representation tycons differ from the tycon in the instance signature in
1348 -- case of instances for indexed families.
1350 genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1353 = return (InstInfo { iSpec = mkInstance oflag (ds_theta spec) spec
1354 , iBinds = NewTypeDerived co }, [])
1357 = do { let loc = getSrcSpan (ds_name spec)
1358 inst = mkInstance oflag (ds_theta spec) spec
1361 -- In case of a family instance, we need to use the representation
1362 -- tycon (after all, it has the data constructors)
1363 ; fix_env <- getFixityEnv
1364 ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1366 -- Build the InstInfo
1367 ; return (InstInfo { iSpec = inst,
1368 iBinds = VanillaInst meth_binds [] },
1372 rep_tycon = ds_tc spec
1373 rep_tc_args = ds_tc_args spec
1374 co1 = case tyConFamilyCoercion_maybe rep_tycon of
1376 Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1377 co2 = case newTyConCo_maybe rep_tycon of
1378 Nothing -> IdCo -- The newtype is transparent; no need for a cast
1379 Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1380 co = co1 `mkTransCoI` co2
1382 -- Example: newtype instance N [a] = N1 (Tree a)
1383 -- deriving instance Eq b => Eq (N [(b,b)])
1384 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1385 -- When dealing with the deriving clause
1386 -- co1 : N [(b,b)] ~ R1:N (b,b)
1387 -- co2 : R1:N (b,b) ~ Tree (b,b)
1389 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1390 genDerivBinds loc fix_env clas tycon
1391 | className clas `elem` typeableClassNames
1392 = (gen_Typeable_binds loc tycon, [])
1395 = case assocMaybe gen_list (getUnique clas) of
1396 Just gen_fn -> gen_fn loc tycon
1397 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1399 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1400 gen_list = [(eqClassKey, gen_Eq_binds)
1401 ,(ordClassKey, gen_Ord_binds)
1402 ,(enumClassKey, gen_Enum_binds)
1403 ,(boundedClassKey, gen_Bounded_binds)
1404 ,(ixClassKey, gen_Ix_binds)
1405 ,(showClassKey, gen_Show_binds fix_env)
1406 ,(readClassKey, gen_Read_binds fix_env)
1407 ,(dataClassKey, gen_Data_binds)
1408 ,(functorClassKey, gen_Functor_binds)
1409 ,(foldableClassKey, gen_Foldable_binds)
1410 ,(traversableClassKey, gen_Traversable_binds)
1415 %************************************************************************
1417 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1419 %************************************************************************
1422 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1423 derivingKindErr tc cls cls_tys cls_kind
1424 = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1425 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1426 2 (ptext (sLit "Class") <+> quotes (ppr cls)
1427 <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1429 derivingEtaErr :: Class -> [Type] -> Type -> Message
1430 derivingEtaErr cls cls_tys inst_ty
1431 = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1432 nest 2 (ptext (sLit "instance (...) =>")
1433 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1435 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1436 typeFamilyPapErr tc cls cls_tys inst_ty
1437 = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1438 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1440 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
1441 derivingThingErr clas tys ty why
1442 = sep [hsep [ptext (sLit "Can't make a derived instance of"),
1444 nest 2 (parens why)]
1446 pred = mkClassPred clas (tys ++ [ty])
1448 derivingHiddenErr :: TyCon -> SDoc
1449 derivingHiddenErr tc
1450 = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1451 2 (ptext (sLit "so you cannot derive an instance for it"))
1453 standaloneCtxt :: LHsType Name -> SDoc
1454 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1457 derivInstCtxt :: Class -> [Type] -> Message
1458 derivInstCtxt clas inst_tys
1459 = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1461 badDerivedPred :: PredType -> Message
1463 = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1464 ptext (sLit "type variables that are not data type parameters"),
1465 nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]