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 (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
805 | cls_key == functorClassKey = Just (cond_functorOK True) -- NB: no cond_std!
806 | cls_key == foldableClassKey = Just (cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
807 | cls_key == traversableClassKey = Just (cond_functorOK False)
808 | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
809 | otherwise = Nothing
811 cls_key = getUnique cls
813 type Condition = (DynFlags, TyCon) -> Maybe SDoc
814 -- first Bool is whether or not we are allowed to derive Data and Typeable
815 -- second Bool is whether or not we are allowed to derive Functor
816 -- TyCon is the *representation* tycon if the
817 -- data type is an indexed one
820 orCond :: Condition -> Condition -> Condition
823 Nothing -> Nothing -- c1 succeeds
824 Just x -> case c2 tc of -- c1 fails
826 Just y -> Just (x $$ ptext (sLit " and") $$ y)
829 andCond :: Condition -> Condition -> Condition
830 andCond c1 c2 tc = case c1 tc of
831 Nothing -> c2 tc -- c1 succeeds
832 Just x -> Just x -- c1 fails
834 cond_std :: Condition
836 | null data_cons = Just no_cons_why
837 | not (null con_whys) = Just (vcat con_whys)
838 | otherwise = Nothing
840 data_cons = tyConDataCons rep_tc
841 no_cons_why = quotes (pprSourceTyCon rep_tc) <+>
842 ptext (sLit "has no data constructors")
844 con_whys = mapCatMaybes check_con data_cons
846 check_con :: DataCon -> Maybe SDoc
848 | isVanillaDataCon con
849 , all isTauTy (dataConOrigArgTys con) = Nothing
850 | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
852 cond_enumOrProduct :: Condition
853 cond_enumOrProduct = cond_isEnumeration `orCond`
854 (cond_isProduct `andCond` cond_noUnliftedArgs)
856 cond_noUnliftedArgs :: Condition
857 -- For some classes (eg Eq, Ord) we allow unlifted arg types
858 -- by generating specilaised code. For others (eg Data) we don't.
859 cond_noUnliftedArgs (_, tc)
860 | null bad_cons = Nothing
861 | otherwise = Just why
863 bad_cons = [ con | con <- tyConDataCons tc
864 , any isUnLiftedType (dataConOrigArgTys con) ]
865 why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
867 cond_isEnumeration :: Condition
868 cond_isEnumeration (_, rep_tc)
869 | isEnumerationTyCon rep_tc = Nothing
870 | otherwise = Just why
872 why = quotes (pprSourceTyCon rep_tc) <+>
873 ptext (sLit "has non-nullary constructors")
875 cond_isProduct :: Condition
876 cond_isProduct (_, rep_tc)
877 | isProductTyCon rep_tc = Nothing
878 | otherwise = Just why
880 why = quotes (pprSourceTyCon rep_tc) <+>
881 ptext (sLit "has more than one constructor")
883 cond_typeableOK :: Condition
884 -- OK for Typeable class
885 -- Currently: (a) args all of kind *
886 -- (b) 7 or fewer args
887 cond_typeableOK (_, rep_tc)
888 | tyConArity rep_tc > 7 = Just too_many
889 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
891 | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts
892 | otherwise = Nothing
894 too_many = quotes (pprSourceTyCon rep_tc) <+>
895 ptext (sLit "has too many arguments")
896 bad_kind = quotes (pprSourceTyCon rep_tc) <+>
897 ptext (sLit "has arguments of kind other than `*'")
898 fam_inst = quotes (pprSourceTyCon rep_tc) <+>
899 ptext (sLit "is a type family")
902 functorLikeClassKeys :: [Unique]
903 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
905 cond_functorOK :: Bool -> Condition
906 -- OK for Functor class
907 -- Currently: (a) at least one argument
908 -- (b) don't use argument contravariantly
909 -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
910 -- (d) optionally: don't use function types
911 cond_functorOK allowFunctions (dflags, rep_tc)
912 | not (dopt Opt_DeriveFunctor dflags)
913 = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
915 = msum (map check_con data_cons) -- msum picks the first 'Just', if any
917 data_cons = tyConDataCons rep_tc
918 check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
920 check_vanilla :: DataCon -> Maybe SDoc
921 check_vanilla con | isVanillaDataCon con = Nothing
922 | otherwise = Just (badCon con existential)
924 ft_check :: DataCon -> FFoldType (Maybe SDoc)
925 ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
926 , ft_co_var = Just (badCon con covariant)
927 , ft_fun = \x y -> if allowFunctions then x `mplus` y
928 else Just (badCon con functions)
929 , ft_tup = \_ xs -> msum xs
930 , ft_ty_app = \_ x -> x
931 , ft_bad_app = Just (badCon con wrong_arg)
932 , ft_forall = \_ x -> x }
934 existential = ptext (sLit "has existential arguments")
935 covariant = ptext (sLit "uses the type variable in a function argument")
936 functions = ptext (sLit "contains function types")
937 wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
939 cond_mayDeriveDataTypeable :: Condition
940 cond_mayDeriveDataTypeable (dflags, _)
941 | dopt Opt_DeriveDataTypeable dflags = Nothing
942 | otherwise = Just why
944 why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
946 std_class_via_iso :: Class -> Bool
947 std_class_via_iso clas -- These standard classes can be derived for a newtype
948 -- using the isomorphism trick *even if no -fglasgow-exts*
949 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
950 -- Not Read/Show because they respect the type
951 -- Not Enum, because newtypes are never in Enum
954 new_dfun_name :: Class -> TyCon -> TcM Name
955 new_dfun_name clas tycon -- Just a simple wrapper
956 = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon
957 ; newDFunName clas [mkTyConApp tycon []] loc }
958 -- The type passed to newDFunName is only used to generate
959 -- a suitable string; hence the empty type arg list
961 badCon :: DataCon -> SDoc -> SDoc
962 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
965 Note [Superclasses of derived instance]
966 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
967 In general, a derived instance decl needs the superclasses of the derived
968 class too. So if we have
969 data T a = ...deriving( Ord )
970 then the initial context for Ord (T a) should include Eq (T a). Often this is
971 redundant; we'll also generate an Ord constraint for each constructor argument,
972 and that will probably generate enough constraints to make the Eq (T a) constraint
973 be satisfied too. But not always; consider:
979 data T a = MkT (S a) deriving( Ord )
980 instance Num a => Eq (T a)
982 The derived instance for (Ord (T a)) must have a (Num a) constraint!
984 data T a = MkT deriving( Data, Typeable )
985 Here there *is* no argument field, but we must nevertheless generate
986 a context for the Data instances:
987 instance Typable a => Data (T a) where ...
990 %************************************************************************
994 %************************************************************************
997 mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class
998 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1000 -> TcRn EarlyDerivSpec
1001 mkNewTypeEqn orig dflags tvs
1002 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1003 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1004 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1005 = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
1006 ; dfun_name <- new_dfun_name cls tycon
1007 ; loc <- getSrcSpanM
1008 ; let spec = DS { ds_loc = loc, ds_orig = orig
1009 , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
1010 , ds_cls = cls, ds_tys = inst_tys
1011 , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1012 , ds_theta = mtheta `orElse` all_preds
1013 , ds_newtype = True }
1014 ; return (if isJust mtheta then Right spec
1018 = case check_conditions of
1019 CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1020 -- Use the standard H98 method
1021 DerivableClassError msg -> bale_out msg -- Error with standard class
1022 NonDerivableClass -- Must use newtype deriving
1023 | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
1024 | otherwise -> bale_out non_std_err -- Try newtype deriving!
1026 newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
1027 check_conditions = checkSideConditions dflags cls cls_tys rep_tycon
1028 bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
1030 non_std_err = nonStdErr cls $$
1031 ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1033 -- Here is the plan for newtype derivings. We see
1034 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1035 -- where t is a type,
1036 -- ak+1...an is a suffix of a1..an, and are all tyars
1037 -- ak+1...an do not occur free in t, nor in the s1..sm
1038 -- (C s1 ... sm) is a *partial applications* of class C
1039 -- with the last parameter missing
1040 -- (T a1 .. ak) matches the kind of C's last argument
1041 -- (and hence so does t)
1042 -- The latter kind-check has been done by deriveTyData already,
1043 -- and tc_args are already trimmed
1045 -- We generate the instance
1046 -- instance forall ({a1..ak} u fvs(s1..sm)).
1047 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
1048 -- where T a1...ap is the partial application of
1049 -- the LHS of the correct kind and p >= k
1051 -- NB: the variables below are:
1052 -- tc_tvs = [a1, ..., an]
1053 -- tyvars_to_keep = [a1, ..., ak]
1054 -- rep_ty = t ak .. an
1055 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
1056 -- tys = [s1, ..., sm]
1059 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1060 -- We generate the instance
1061 -- instance Monad (ST s) => Monad (T s) where
1063 nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1064 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1065 -- eta-reduces the representation type, so we know that
1067 -- That's convenient here, because we may have to apply
1068 -- it to fewer than its original complement of arguments
1070 -- Note [Newtype representation]
1071 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1072 -- Need newTyConRhs (*not* a recursive representation finder)
1073 -- to get the representation type. For example
1074 -- newtype B = MkB Int
1075 -- newtype A = MkA B deriving( Num )
1076 -- We want the Num instance of B, *not* the Num instance of Int,
1077 -- when making the Num instance of A!
1078 rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1079 rep_tys = cls_tys ++ [rep_inst_ty]
1080 rep_pred = mkClassPred cls rep_tys
1081 -- rep_pred is the representation dictionary, from where
1082 -- we are gong to get all the methods for the newtype
1086 -- Next we figure out what superclass dictionaries to use
1087 -- See Note [Newtype deriving superclasses] above
1089 cls_tyvars = classTyVars cls
1090 dfun_tvs = tyVarsOfTypes inst_tys
1091 inst_ty = mkTyConApp tycon tc_args
1092 inst_tys = cls_tys ++ [inst_ty]
1093 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1096 -- If there are no tyvars, there's no need
1097 -- to abstract over the dictionaries we need
1098 -- Example: newtype T = MkT Int deriving( C )
1099 -- We get the derived instance
1102 -- instance C Int => C T
1103 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
1105 -------------------------------------------------------------------
1106 -- Figuring out whether we can only do this newtype-deriving thing
1108 can_derive_via_isomorphism
1109 = not (non_iso_class cls)
1113 -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
1115 -- Never derive Read,Show,Typeable,Data by isomorphism
1116 non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
1119 arity_ok = length cls_tys + 1 == classArity cls
1120 -- Well kinded; eg not: newtype T ... deriving( ST )
1121 -- because ST needs *2* type params
1123 -- Check that eta reduction is OK
1124 eta_ok = nt_eta_arity <= length rep_tc_args
1125 -- The newtype can be eta-reduced to match the number
1126 -- of type argument actually supplied
1127 -- newtype T a b = MkT (S [a] b) deriving( Monad )
1128 -- Here the 'b' must be the same in the rep type (S [a] b)
1129 -- And the [a] must not mention 'b'. That's all handled
1132 ats_ok = null (classATs cls)
1133 -- No associated types for the class, because we don't
1134 -- currently generate type 'instance' decls; and cannot do
1135 -- so for 'data' instance decls
1138 = vcat [ ptext (sLit "even with cunning newtype deriving:")
1139 , if arity_ok then empty else arity_msg
1140 , if eta_ok then empty else eta_msg
1141 , if ats_ok then empty else ats_msg ]
1142 arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1143 eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
1144 ats_msg = ptext (sLit "the class has associated types")
1147 Note [Recursive newtypes]
1148 ~~~~~~~~~~~~~~~~~~~~~~~~~
1149 Newtype deriving works fine, even if the newtype is recursive.
1150 e.g. newtype S1 = S1 [T1 ()]
1151 newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1152 Remember, too, that type families are curretly (conservatively) given
1153 a recursive flag, so this also allows newtype deriving to work
1156 We used to exclude recursive types, because we had a rather simple
1157 minded way of generating the instance decl:
1159 instance Eq [A] => Eq A -- Makes typechecker loop!
1160 But now we require a simple context, so it's ok.
1163 %************************************************************************
1165 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1167 %************************************************************************
1169 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1170 terms, which is the final correct RHS for the corresponding original
1174 Each (k,TyVarTy tv) in a solution constrains only a type
1178 The (k,TyVarTy tv) pairs in a solution are canonically
1179 ordered by sorting on type varible, tv, (major key) and then class, k,
1184 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1186 inferInstanceContexts _ [] = return []
1188 inferInstanceContexts oflag infer_specs
1189 = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
1190 ; iterate_deriv 1 initial_solutions }
1192 ------------------------------------------------------------------
1193 -- The initial solutions for the equations claim that each
1194 -- instance has an empty context; this solution is certainly
1195 -- in canonical form.
1196 initial_solutions :: [ThetaType]
1197 initial_solutions = [ [] | _ <- infer_specs ]
1199 ------------------------------------------------------------------
1200 -- iterate_deriv calculates the next batch of solutions,
1201 -- compares it with the current one; finishes if they are the
1202 -- same, otherwise recurses with the new solutions.
1203 -- It fails if any iteration fails
1204 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1205 iterate_deriv n current_solns
1206 | n > 20 -- Looks as if we are in an infinite loop
1207 -- This can happen if we have -XUndecidableInstances
1208 -- (See TcSimplify.tcSimplifyDeriv.)
1209 = pprPanic "solveDerivEqns: probable loop"
1210 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1212 = do { -- Extend the inst info from the explicit instance decls
1213 -- with the current set of solutions, and simplify each RHS
1214 let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1215 current_solns infer_specs
1216 ; new_solns <- checkNoErrs $
1217 extendLocalInstEnv inst_specs $
1218 mapM gen_soln infer_specs
1220 ; if (current_solns == new_solns) then
1221 return [ spec { ds_theta = soln }
1222 | (spec, soln) <- zip infer_specs current_solns ]
1224 iterate_deriv (n+1) new_solns }
1226 ------------------------------------------------------------------
1227 gen_soln :: DerivSpec -> TcM [PredType]
1228 gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1229 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1231 addErrCtxt (derivInstCtxt clas inst_tys) $
1232 do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
1233 -- checkValidInstance tyvars theta clas inst_tys
1234 -- Not necessary; see Note [Exotic derived instance contexts]
1237 -- Check for a bizarre corner case, when the derived instance decl should
1238 -- have form instance C a b => D (T a) where ...
1239 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1240 -- of problems; in particular, it's hard to compare solutions for
1241 -- equality when finding the fixpoint. So I just rule it out for now.
1242 ; let tv_set = mkVarSet tyvars
1243 weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
1244 ; mapM_ (addErrTc . badDerivedPred) weird_preds
1246 -- Claim: the result instance declaration is guaranteed valid
1247 -- Hence no need to call:
1248 -- checkValidInstance tyvars theta clas inst_tys
1249 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
1251 ------------------------------------------------------------------
1252 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1253 mkInstance overlap_flag theta
1254 (DS { ds_name = dfun_name
1255 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1256 = mkLocalInstance dfun overlap_flag
1258 dfun = mkDictFunId dfun_name tyvars theta clas tys
1261 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1262 -- Add new locally-defined instances; don't bother to check
1263 -- for functional dependency errors -- that'll happen in TcInstDcls
1264 extendLocalInstEnv dfuns thing_inside
1265 = do { env <- getGblEnv
1266 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1267 env' = env { tcg_inst_env = inst_env' }
1268 ; setGblEnv env' thing_inside }
1272 %************************************************************************
1274 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1276 %************************************************************************
1278 After all the trouble to figure out the required context for the
1279 derived instance declarations, all that's left is to chug along to
1280 produce them. They will then be shoved into @tcInstDecls2@, which
1281 will do all its usual business.
1283 There are lots of possibilities for code to generate. Here are
1284 various general remarks.
1289 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1290 ``you-couldn't-do-better-by-hand'' efficient.
1293 Deriving @Show@---also pretty common--- should also be reasonable good code.
1296 Deriving for the other classes isn't that common or that big a deal.
1303 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1306 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1309 We {\em normally} generate code only for the non-defaulted methods;
1310 there are some exceptions for @Eq@ and (especially) @Ord@...
1313 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1314 constructor's numeric (@Int#@) tag. These are generated by
1315 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1316 these is around is given by @hasCon2TagFun@.
1318 The examples under the different sections below will make this
1322 Much less often (really just for deriving @Ix@), we use a
1323 @_tag2con_<tycon>@ function. See the examples.
1326 We use the renamer!!! Reason: we're supposed to be
1327 producing @LHsBinds Name@ for the methods, but that means
1328 producing correctly-uniquified code on the fly. This is entirely
1329 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1330 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1331 the renamer. What a great hack!
1335 -- Generate the InstInfo for the required instance paired with the
1336 -- *representation* tycon for that instance,
1337 -- plus any auxiliary bindings required
1339 -- Representation tycons differ from the tycon in the instance signature in
1340 -- case of instances for indexed families.
1342 genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1345 = return (InstInfo { iSpec = mkInstance oflag (ds_theta spec) spec
1346 , iBinds = NewTypeDerived co }, [])
1349 = do { let loc = getSrcSpan (ds_name spec)
1350 inst = mkInstance oflag (ds_theta spec) spec
1353 -- In case of a family instance, we need to use the representation
1354 -- tycon (after all, it has the data constructors)
1355 ; fix_env <- getFixityEnv
1356 ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1358 -- Build the InstInfo
1359 ; return (InstInfo { iSpec = inst,
1360 iBinds = VanillaInst meth_binds [] },
1364 rep_tycon = ds_tc spec
1365 rep_tc_args = ds_tc_args spec
1366 co1 = case tyConFamilyCoercion_maybe rep_tycon of
1368 Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1369 co2 = case newTyConCo_maybe rep_tycon of
1370 Nothing -> IdCo -- The newtype is transparent; no need for a cast
1371 Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1372 co = co1 `mkTransCoI` co2
1374 -- Example: newtype instance N [a] = N1 (Tree a)
1375 -- deriving instance Eq b => Eq (N [(b,b)])
1376 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1377 -- When dealing with the deriving clause
1378 -- co1 : N [(b,b)] ~ R1:N (b,b)
1379 -- co2 : R1:N (b,b) ~ Tree (b,b)
1381 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1382 genDerivBinds loc fix_env clas tycon
1383 | className clas `elem` typeableClassNames
1384 = (gen_Typeable_binds loc tycon, [])
1387 = case assocMaybe gen_list (getUnique clas) of
1388 Just gen_fn -> gen_fn loc tycon
1389 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1391 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1392 gen_list = [(eqClassKey, gen_Eq_binds)
1393 ,(ordClassKey, gen_Ord_binds)
1394 ,(enumClassKey, gen_Enum_binds)
1395 ,(boundedClassKey, gen_Bounded_binds)
1396 ,(ixClassKey, gen_Ix_binds)
1397 ,(showClassKey, gen_Show_binds fix_env)
1398 ,(readClassKey, gen_Read_binds fix_env)
1399 ,(dataClassKey, gen_Data_binds)
1400 ,(functorClassKey, gen_Functor_binds)
1401 ,(foldableClassKey, gen_Foldable_binds)
1402 ,(traversableClassKey, gen_Traversable_binds)
1407 %************************************************************************
1409 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1411 %************************************************************************
1414 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1415 derivingKindErr tc cls cls_tys cls_kind
1416 = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1417 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1418 2 (ptext (sLit "Class") <+> quotes (ppr cls)
1419 <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1421 derivingEtaErr :: Class -> [Type] -> Type -> Message
1422 derivingEtaErr cls cls_tys inst_ty
1423 = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1424 nest 2 (ptext (sLit "instance (...) =>")
1425 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1427 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1428 typeFamilyPapErr tc cls cls_tys inst_ty
1429 = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1430 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1432 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
1433 derivingThingErr clas tys ty why
1434 = sep [hsep [ptext (sLit "Can't make a derived instance of"),
1436 nest 2 (parens why)]
1438 pred = mkClassPred clas (tys ++ [ty])
1440 derivingHiddenErr :: TyCon -> SDoc
1441 derivingHiddenErr tc
1442 = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1443 2 (ptext (sLit "so you cannot derive an instance for it"))
1445 standaloneCtxt :: LHsType Name -> SDoc
1446 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1449 derivInstCtxt :: Class -> [Type] -> Message
1450 derivInstCtxt clas inst_tys
1451 = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1453 badDerivedPred :: PredType -> Message
1455 = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1456 ptext (sLit "type variables that are not data type parameters"),
1457 nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]