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
60 %************************************************************************
64 %************************************************************************
68 1. Convert the decls (i.e. data/newtype deriving clauses,
69 plus standalone deriving) to [EarlyDerivSpec]
71 2. Infer the missing contexts for the Left DerivSpecs
73 3. Add the derived bindings, generating InstInfos
77 -- DerivSpec is purely local to this module
78 data DerivSpec = DS { ds_loc :: SrcSpan
82 , ds_theta :: ThetaType
86 , ds_tc_args :: [Type]
87 , ds_newtype :: Bool }
88 -- This spec implies a dfun declaration of the form
89 -- df :: forall tvs. theta => C tys
90 -- The Name is the name for the DFun we'll build
91 -- The tyvars bind all the variables in the theta
92 -- For type families, the tycon in
93 -- in ds_tys is the *family* tycon
94 -- in ds_tc, ds_tc_args is the *representation* tycon
95 -- For non-family tycons, both are the same
97 -- ds_newtype = True <=> Newtype deriving
98 -- False <=> Vanilla deriving
103 newtype instance T [a] = MkT (Tree a) deriving( C s )
105 axiom T [a] = :RTList a
106 axiom :RTList a = Tree a
108 DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
109 , ds_tc = :RTList, ds_tc_args = [a]
110 , ds_newtype = True }
113 type DerivContext = Maybe ThetaType
114 -- Nothing <=> Vanilla deriving; infer the context of the instance decl
115 -- Just theta <=> Standalone deriving: context supplied by programmer
117 type EarlyDerivSpec = Either DerivSpec DerivSpec
118 -- Left ds => the context for the instance should be inferred
119 -- In this case ds_theta is the list of all the
120 -- constraints needed, such as (Eq [a], Eq a)
121 -- The inference process is to reduce this to a
122 -- simpler form (e.g. Eq a)
124 -- Right ds => the exact context for the instance is supplied
125 -- by the programmer; it is ds_theta
127 pprDerivSpec :: DerivSpec -> SDoc
128 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
129 ds_cls = c, ds_tys = tys, ds_theta = rhs })
130 = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
131 <+> equals <+> ppr rhs)
135 Inferring missing contexts
136 ~~~~~~~~~~~~~~~~~~~~~~~~~~
139 data T a b = C1 (Foo a) (Bar b)
144 [NOTE: See end of these comments for what to do with
145 data (C a, D b) => T a b = ...
148 We want to come up with an instance declaration of the form
150 instance (Ping a, Pong b, ...) => Eq (T a b) where
153 It is pretty easy, albeit tedious, to fill in the code "...". The
154 trick is to figure out what the context for the instance decl is,
155 namely @Ping@, @Pong@ and friends.
157 Let's call the context reqd for the T instance of class C at types
158 (a,b, ...) C (T a b). Thus:
160 Eq (T a b) = (Ping a, Pong b, ...)
162 Now we can get a (recursive) equation from the @data@ decl:
164 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
165 u Eq (T b a) u Eq Int -- From C2
166 u Eq (T a a) -- From C3
168 Foo and Bar may have explicit instances for @Eq@, in which case we can
169 just substitute for them. Alternatively, either or both may have
170 their @Eq@ instances given by @deriving@ clauses, in which case they
171 form part of the system of equations.
173 Now all we need do is simplify and solve the equations, iterating to
174 find the least fixpoint. Notice that the order of the arguments can
175 switch around, as here in the recursive calls to T.
177 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
181 Eq (T a b) = {} -- The empty set
184 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
185 u Eq (T b a) u Eq Int -- From C2
186 u Eq (T a a) -- From C3
188 After simplification:
189 = Eq a u Ping b u {} u {} u {}
194 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
195 u Eq (T b a) u Eq Int -- From C2
196 u Eq (T a a) -- From C3
198 After simplification:
203 = Eq a u Ping b u Eq b u Ping a
205 The next iteration gives the same result, so this is the fixpoint. We
206 need to make a canonical form of the RHS to ensure convergence. We do
207 this by simplifying the RHS to a form in which
209 - the classes constrain only tyvars
210 - the list is sorted by tyvar (major key) and then class (minor key)
211 - no duplicates, of course
213 So, here are the synonyms for the ``equation'' structures:
216 Note [Data decl contexts]
217 ~~~~~~~~~~~~~~~~~~~~~~~~~
220 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
222 We will need an instance decl like:
224 instance (Read a, RealFloat a) => Read (Complex a) where
227 The RealFloat in the context is because the read method for Complex is bound
228 to construct a Complex, and doing that requires that the argument type is
231 But this ain't true for Show, Eq, Ord, etc, since they don't construct
232 a Complex; they only take them apart.
234 Our approach: identify the offending classes, and add the data type
235 context to the instance decl. The "offending classes" are
239 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
240 pattern matching against a constructor from a data type with a context
241 gives rise to the constraints for that context -- or at least the thinned
242 version. So now all classes are "offending".
244 Note [Newtype deriving]
245 ~~~~~~~~~~~~~~~~~~~~~~~
249 newtype T = T Char deriving( C [a] )
251 Notice the free 'a' in the deriving. We have to fill this out to
252 newtype T = T Char deriving( forall a. C [a] )
254 And then translate it to:
255 instance C [a] Char => C [a] T where ...
258 Note [Newtype deriving superclasses]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 (See also Trac #1220 for an interesting exchange on newtype
261 deriving and superclasses.)
263 The 'tys' here come from the partial application in the deriving
264 clause. The last arg is the new instance type.
266 We must pass the superclasses; the newtype might be an instance
267 of them in a different way than the representation type
268 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
269 Then the Show instance is not done via isomorphism; it shows
271 The Num instance is derived via isomorphism, but the Show superclass
272 dictionary must the Show instance for Foo, *not* the Show dictionary
273 gotten from the Num dictionary. So we must build a whole new dictionary
274 not just use the Num one. The instance we want is something like:
275 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
278 There may be a coercion needed which we get from the tycon for the newtype
279 when the dict is constructed in TcInstDcls.tcInstDecl2
282 Note [Unused constructors and deriving clauses]
283 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
284 See Trac #3221. Consider
285 data T = T1 | T2 deriving( Show )
286 Are T1 and T2 unused? Well, no: the deriving clause expands to mention
287 both of them. So we gather defs/uses from deriving just like anything else.
289 %************************************************************************
291 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
293 %************************************************************************
296 tcDeriving :: [LTyClDecl Name] -- All type constructors
297 -> [LInstDecl Name] -- All instance declarations
298 -> [LDerivDecl Name] -- All stand-alone deriving declarations
299 -> TcM ([InstInfo Name] -- The generated "instance decls"
300 ,HsValBinds Name -- Extra generated top-level bindings
302 ,[TyCon] -- Extra generated top-level types
303 ,[TyCon]) -- Extra generated type family instances
305 tcDeriving tycl_decls inst_decls deriv_decls
306 = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
307 do { -- Fish the "deriving"-related information out of the TcEnv
308 -- And make the necessary "equations".
309 is_boot <- tcIsHsBoot
310 ; traceTc "tcDeriving" (ppr is_boot)
311 ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
313 ; overlap_flag <- getOverlapFlag
314 ; let (infer_specs, given_specs) = splitEithers early_specs
315 ; insts1 <- mapM (genInst True overlap_flag) given_specs
317 ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
318 inferInstanceContexts overlap_flag infer_specs
320 ; insts2 <- mapM (genInst False overlap_flag) final_specs
322 -- Generate the (old) generic to/from functions from each type declaration
323 ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
325 -- Generate the generic Representable0/1 instances from each type declaration
326 ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls
328 ; let repInsts = concat (map (\(a,b,c) -> a) repInstsMeta)
329 repMetaTys = map (\(a,b,c) -> b) repInstsMeta
330 repTyCons = map (\(a,b,c) -> c) repInstsMeta
331 -- Should we extendLocalInstEnv with repInsts?
333 ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ repInsts)
336 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
337 (ddump_deriving inst_info rn_binds))
339 ; when (not (null inst_info)) $
340 dumpDerivingInfo (ddump_deriving inst_info rn_binds)
341 ; return ( inst_info, rn_binds, rn_dus
342 , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
344 ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
345 ddump_deriving inst_infos extra_binds
346 = hang (ptext (sLit "Derived instances"))
347 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
350 renameDeriv :: Bool -> LHsBinds RdrName
351 -> [(InstInfo RdrName, DerivAuxBinds)]
352 -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
353 renameDeriv is_boot gen_binds insts
354 | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
355 -- The inst-info bindings will all be empty, but it's easier to
356 -- just use rn_inst_info to change the type appropriately
357 = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
358 ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
361 = discardWarnings $ -- Discard warnings about unused bindings etc
362 do { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns
363 -- are used in the generic binds
364 rnTopBinds (ValBindsIn gen_binds [])
365 ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive
367 -- Generate and rename any extra not-one-inst-decl-specific binds,
368 -- notably "con2tag" and/or "tag2con" functions.
369 -- Bring those names into scope before renaming the instances themselves
370 ; loc <- getSrcSpanM -- Generic loc for shared bindings
371 ; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $
372 rm_dups [] $ concat deriv_aux_binds
373 aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
374 ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
375 ; bindLocalNames (collectHsValBinders rn_aux_lhs) $
376 do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
377 ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
378 ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
379 dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
382 (inst_infos, deriv_aux_binds) = unzip insts
384 -- Remove duplicate requests for auxilliary bindings
386 rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
387 | otherwise = rm_dups (b:acc) bs
390 rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
391 rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
392 = return ( info { iBinds = NewTypeDerived coi tc }
393 , mkFVs (map dataConName (tyConDataCons tc)))
394 -- See Note [Newtype deriving and unused constructors]
396 rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
397 = -- Bring the right type variables into
398 -- scope (yuk), and rename the method binds
400 bindLocalNames (map Var.varName tyvars) $
401 do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
402 ; let binds' = VanillaInst rn_binds [] standalone_deriv
403 ; return (inst_info { iBinds = binds' }, fvs) }
405 (tyvars,_, clas,_) = instanceHead inst
406 clas_nm = className clas
408 -----------------------------------------
409 mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
410 mkGenericBinds is_boot tycl_decls
414 = do { tcs <- mapM tcLookupTyCon [ tcdName d
415 | L _ d <- tycl_decls, isDataDecl d ]
416 ; return (unionManyBags [ mkTyConGenericBinds tc
417 | tc <- tcs, tyConHasGenerics tc ]) }
418 -- We are only interested in the data type declarations,
419 -- and then only in the ones whose 'has-generics' flag is on
420 -- The predicate tyConHasGenerics finds both of these
423 Note [Newtype deriving and unused constructors]
424 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
425 Consider this (see Trac #1954):
428 newtype P a = MkP (IO a) deriving Monad
430 If you compile with -fwarn-unused-binds you do not expect the warning
431 "Defined but not used: data consructor MkP". Yet the newtype deriving
432 code does not explicitly mention MkP, but it should behave as if you
434 instance Monad P where
435 return x = MkP (return x)
438 So we want to signal a user of the data constructor 'MkP'. That's
439 what we do in rn_inst_info, and it's the only reason we have the TyCon
440 stored in NewTypeDerived.
443 %************************************************************************
445 From HsSyn to DerivSpec
447 %************************************************************************
449 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
452 makeDerivSpecs :: Bool
456 -> TcM [EarlyDerivSpec]
458 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
459 | is_boot -- No 'deriving' at all in hs-boot files
460 = do { mapM_ add_deriv_err deriv_locs
463 = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
464 ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
465 ; return (eqns1 ++ eqns2) }
467 extractTyDataPreds decls
468 = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
470 all_tydata :: [(LHsType Name, LTyClDecl Name)]
471 -- Derived predicate paired with its data type declaration
472 all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
474 deriv_locs = map (getLoc . snd) all_tydata
475 ++ map getLoc deriv_decls
477 add_deriv_err loc = setSrcSpan loc $
478 addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
479 2 (ptext (sLit "Use an instance declaration instead")))
481 ------------------------------------------------------------------
482 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
483 -- Standalone deriving declarations
484 -- e.g. deriving instance Show a => Show (T a)
485 -- Rather like tcLocalInstDecl
486 deriveStandalone (L loc (DerivDecl deriv_ty))
488 addErrCtxt (standaloneCtxt deriv_ty) $
489 do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
490 ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty
491 ; traceTc "Standalone deriving;" $ vcat
492 [ text "tvs:" <+> ppr tvs
493 , text "theta:" <+> ppr theta
494 , text "cls:" <+> ppr cls
495 , text "tys:" <+> ppr inst_tys ]
496 ; checkValidInstance deriv_ty tvs theta cls inst_tys
497 -- C.f. TcInstDcls.tcLocalInstDecl1
499 ; let cls_tys = take (length inst_tys - 1) inst_tys
500 inst_ty = last inst_tys
501 ; traceTc "Standalone deriving:" $ vcat
502 [ text "class:" <+> ppr cls
503 , text "class types:" <+> ppr cls_tys
504 , text "type:" <+> ppr inst_ty ]
505 ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
508 ------------------------------------------------------------------
509 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
510 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
511 tcdTyVars = tv_names,
512 tcdTyPats = ty_pats }))
513 = setSrcSpan loc $ -- Use the location of the 'deriving' item
515 do { (tvs, tc, tc_args) <- get_lhs ty_pats
516 ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
517 -- the type variables for the type constructor
519 do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
520 -- The "deriv_pred" is a LHsType to take account of the fact that for
521 -- newtype deriving we allow deriving (forall a. C [a]).
523 -- Given data T a b c = ... deriving( C d ),
524 -- we want to drop type variables from T so that (C d (T a)) is well-kinded
525 ; let cls_tyvars = classTyVars cls
526 kind = tyVarKind (last cls_tyvars)
527 (arg_kinds, _) = splitKindFunTys kind
528 n_args_to_drop = length arg_kinds
529 n_args_to_keep = tyConArity tc - n_args_to_drop
530 args_to_drop = drop n_args_to_keep tc_args
531 inst_ty = mkTyConApp tc (take n_args_to_keep tc_args)
532 inst_ty_kind = typeKind inst_ty
533 dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
534 univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
535 `minusVarSet` dropped_tvs
537 -- Check that the result really is well-kinded
538 ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
539 (derivingKindErr tc cls cls_tys kind)
541 ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a)
542 tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
543 (derivingEtaErr cls cls_tys inst_ty)
545 -- (a) The data type can be eta-reduced; eg reject:
546 -- data instance T a a = ... deriving( Monad )
547 -- (b) The type class args do not mention any of the dropped type
549 -- newtype T a s = ... deriving( ST s )
551 -- Type families can't be partially applied
552 -- e.g. newtype instance T Int a = MkT [a] deriving( Monad )
553 -- Note [Deriving, type families, and partial applications]
554 ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
555 (typeFamilyPapErr tc cls cls_tys inst_ty)
557 ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
559 -- Tiresomely we must figure out the "lhs", which is awkward for type families
560 -- E.g. data T a b = .. deriving( Eq )
561 -- Here, the lhs is (T a b)
562 -- data instance TF Int b = ... deriving( Eq )
563 -- Here, the lhs is (TF Int b)
564 -- But if we just look up the tycon_name, we get is the *family*
565 -- tycon, but not pattern types -- they are in the *rep* tycon.
566 get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
567 ; let tvs = tyConTyVars tc
568 ; return (tvs, tc, mkTyVarTys tvs) }
569 get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
570 ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
571 ; let (tc, tc_args) = tcSplitTyConApp tc_app
572 ; return (tvs, tc, tc_args) }
575 = panic "derivTyData" -- Caller ensures that only TyData can happen
578 Note [Deriving, type families, and partial applications]
579 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
580 When there are no type families, it's quite easy:
582 newtype S a = MkS [a]
583 -- :CoS :: S ~ [] -- Eta-reduced
585 instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
586 instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
588 When type familes are involved it's trickier:
591 newtype instance T Int a = MkT [a] deriving( Eq, Monad )
592 -- :RT is the representation type for (T Int a)
593 -- :CoF:R1T a :: T Int a ~ :RT a -- Not eta reduced
594 -- :Co:R1T :: :RT ~ [] -- Eta-reduced
596 instance Eq [a] => Eq (T Int a) -- easy by coercion
597 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
599 The "???" bit is that we don't build the :CoF thing in eta-reduced form
600 Henc the current typeFamilyPapErr, even though the instance makes sense.
601 After all, we can write it out
602 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
607 mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
608 -> DerivContext -- Just => context supplied (standalone deriving)
609 -- Nothing => context inferred (deriving on data decl)
610 -> TcRn EarlyDerivSpec
611 -- Make the EarlyDerivSpec for an instance
612 -- forall tvs. theta => cls (tys ++ [ty])
613 -- where the 'theta' is optional (that's the Maybe part)
614 -- Assumes that this declaration is well-kinded
616 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
617 | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
618 , isAlgTyCon tycon -- Check for functions, primitive types etc
619 = mk_alg_eqn tycon tc_args
621 = failWithTc (derivingThingErr False cls cls_tys tc_app
622 (ptext (sLit "The last argument of the instance must be a data or newtype application")))
625 bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
627 mk_alg_eqn tycon tc_args
628 | className cls `elem` typeableClassNames
629 = do { dflags <- getDOpts
630 ; case checkTypeableConditions (dflags, tycon) of
631 Just err -> bale_out err
632 Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta }
634 | isDataFamilyTyCon tycon
635 , length tc_args /= tyConArity tycon
636 = bale_out (ptext (sLit "Unsaturated data family application"))
639 = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
640 -- Be careful to test rep_tc here: in the case of families,
641 -- we want to check the instance tycon, not the family tycon
643 -- For standalone deriving (mtheta /= Nothing),
644 -- check that all the data constructors are in scope.
645 ; rdr_env <- getGlobalRdrEnv
646 ; let hidden_data_cons = isAbstractTyCon rep_tc ||
647 any not_in_scope (tyConDataCons rep_tc)
648 not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))
649 ; unless (isNothing mtheta || not hidden_data_cons)
650 (bale_out (derivingHiddenErr tycon))
653 ; if isDataTyCon rep_tc then
654 mkDataTypeEqn orig dflags tvs cls cls_tys
655 tycon tc_args rep_tc rep_tc_args mtheta
657 mkNewTypeEqn orig dflags tvs cls cls_tys
658 tycon tc_args rep_tc rep_tc_args mtheta }
662 %************************************************************************
666 %************************************************************************
669 mkDataTypeEqn :: CtOrigin
671 -> [Var] -- Universally quantified type variables in the instance
672 -> Class -- Class for which we need to derive an instance
673 -> [Type] -- Other parameters to the class except the last
674 -> TyCon -- Type constructor for which the instance is requested
675 -- (last parameter to the type class)
676 -> [Type] -- Parameters to the type constructor
677 -> TyCon -- rep of the above (for type families)
678 -> [Type] -- rep of the above
679 -> DerivContext -- Context of the instance, for standalone deriving
680 -> TcRn EarlyDerivSpec -- Return 'Nothing' if error
682 mkDataTypeEqn orig dflags tvs cls cls_tys
683 tycon tc_args rep_tc rep_tc_args mtheta
684 = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
685 -- NB: pass the *representation* tycon to checkSideConditions
686 CanDerive -> go_for_it
687 NonDerivableClass -> bale_out (nonStdErr cls)
688 DerivableClassError msg -> bale_out msg
690 go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
691 bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
693 mk_data_eqn :: CtOrigin -> [TyVar] -> Class
694 -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
695 -> TcM EarlyDerivSpec
696 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
697 = do { dfun_name <- new_dfun_name cls tycon
699 ; let inst_tys = [mkTyConApp tycon tc_args]
700 inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
701 spec = DS { ds_loc = loc, ds_orig = orig
702 , ds_name = dfun_name, ds_tvs = tvs
703 , ds_cls = cls, ds_tys = inst_tys
704 , ds_tc = rep_tc, ds_tc_args = rep_tc_args
705 , ds_theta = mtheta `orElse` inferred_constraints
706 , ds_newtype = False }
708 ; return (if isJust mtheta then Right spec -- Specified context
709 else Left spec) } -- Infer context
711 ----------------------
712 mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
713 -> TyCon -> [TcType] -> DerivContext
714 -> TcM EarlyDerivSpec
715 mk_typeable_eqn orig tvs cls tycon tc_args mtheta
716 -- The Typeable class is special in several ways
717 -- data T a b = ... deriving( Typeable )
719 -- instance Typeable2 T where ...
721 -- 1. There are no constraints in the instance
722 -- 2. There are no type variables either
723 -- 3. The actual class we want to generate isn't necessarily
724 -- Typeable; it depends on the arity of the type
725 | isNothing mtheta -- deriving on a data type decl
726 = do { checkTc (cls `hasKey` typeableClassKey)
727 (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
728 ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
729 ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
731 | otherwise -- standaone deriving
732 = do { checkTc (null tc_args)
733 (ptext (sLit "Derived typeable instance must be of form (Typeable")
734 <> int (tyConArity tycon) <+> ppr tycon <> rparen)
735 ; dfun_name <- new_dfun_name cls tycon
738 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
739 , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
740 , ds_tc = tycon, ds_tc_args = []
741 , ds_theta = mtheta `orElse` [], ds_newtype = False }) }
743 ----------------------
744 inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
745 -- Generate a sufficiently large set of constraints that typechecking the
746 -- generated method definitions should succeed. This set will be simplified
747 -- before being used in the instance declaration
748 inferConstraints _ cls inst_tys rep_tc rep_tc_args
749 = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
750 stupid_constraints ++ extra_constraints
751 ++ sc_constraints ++ con_arg_constraints
753 -- Constraints arising from the arguments of each constructor
755 = [ mkClassPred cls [arg_ty]
756 | data_con <- tyConDataCons rep_tc,
757 arg_ty <- ASSERT( isVanillaDataCon data_con )
758 get_constrained_tys $
759 dataConInstOrigArgTys data_con all_rep_tc_args,
760 not (isUnLiftedType arg_ty) ]
761 -- No constraints for unlifted types
762 -- Where they are legal we generate specilised function calls
764 -- For functor-like classes, two things are different
765 -- (a) We recurse over argument types to generate constraints
766 -- See Functor examples in TcGenDeriv
767 -- (b) The rep_tc_args will be one short
768 is_functor_like = getUnique cls `elem` functorLikeClassKeys
770 get_constrained_tys :: [Type] -> [Type]
771 get_constrained_tys tys
772 | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
775 rep_tc_tvs = tyConTyVars rep_tc
776 last_tv = last rep_tc_tvs
777 all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
778 | otherwise = rep_tc_args
780 -- Constraints arising from superclasses
781 -- See Note [Superclasses of derived instance]
782 sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
785 -- Stupid constraints
786 stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
787 subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
789 -- Extra Data constraints
790 -- The Data class (only) requires that for
791 -- instance (...) => Data (T t1 t2)
793 -- THEN (Data t1, Data t2) are among the (...) constraints
794 -- Reason: when the IF holds, we generate a method
795 -- dataCast2 f = gcast2 f
796 -- and we need the Data constraints to typecheck the method
798 | cls `hasKey` dataClassKey
799 , all (isLiftedTypeKind . typeKind) rep_tc_args
800 = [mkClassPred cls [ty] | ty <- rep_tc_args]
804 ------------------------------------------------------------------
805 -- Check side conditions that dis-allow derivability for particular classes
806 -- This is *apart* from the newtype-deriving mechanism
808 -- Here we get the representation tycon in case of family instances as it has
809 -- the data constructors - but we need to be careful to fall back to the
810 -- family tycon (with indexes) in error messages.
812 data DerivStatus = CanDerive
813 | DerivableClassError SDoc -- Standard class, but can't do it
814 | NonDerivableClass -- Non-standard class
816 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus
817 checkSideConditions dflags mtheta cls cls_tys rep_tc
818 | Just cond <- sideConditions mtheta cls
819 = case (cond (dflags, rep_tc)) of
820 Just err -> DerivableClassError err -- Class-specific error
821 Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so
822 -- cls_tys (the type args other than last)
824 | otherwise -> DerivableClassError ty_args_why -- e.g. deriving( Eq s )
825 | otherwise = NonDerivableClass -- Not a standard class
827 ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
829 checkTypeableConditions :: Condition
830 checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
832 nonStdErr :: Class -> SDoc
833 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
835 sideConditions :: DerivContext -> Class -> Maybe Condition
836 sideConditions mtheta cls
837 | cls_key == eqClassKey = Just cond_std
838 | cls_key == ordClassKey = Just cond_std
839 | cls_key == showClassKey = Just cond_std
840 | cls_key == readClassKey = Just (cond_std `andCond` cond_noUnliftedArgs)
841 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
842 | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
843 | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
844 | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond`
845 cond_std `andCond` cond_noUnliftedArgs)
846 | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond`
847 cond_functorOK True) -- NB: no cond_std!
848 | cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond`
849 cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
850 | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
851 cond_functorOK False)
852 | otherwise = Nothing
854 cls_key = getUnique cls
855 cond_std = cond_stdOK mtheta
857 type Condition = (DynFlags, TyCon) -> Maybe SDoc
858 -- first Bool is whether or not we are allowed to derive Data and Typeable
859 -- second Bool is whether or not we are allowed to derive Functor
860 -- TyCon is the *representation* tycon if the
861 -- data type is an indexed one
864 orCond :: Condition -> Condition -> Condition
867 Nothing -> Nothing -- c1 succeeds
868 Just x -> case c2 tc of -- c1 fails
870 Just y -> Just (x $$ ptext (sLit " and") $$ y)
873 andCond :: Condition -> Condition -> Condition
874 andCond c1 c2 tc = case c1 tc of
875 Nothing -> c2 tc -- c1 succeeds
876 Just x -> Just x -- c1 fails
878 cond_stdOK :: DerivContext -> Condition
879 cond_stdOK (Just _) _
880 = Nothing -- Don't check these conservative conditions for
881 -- standalone deriving; just generate the code
882 -- and let the typechecker handle the result
883 cond_stdOK Nothing (_, rep_tc)
884 | null data_cons = Just (no_cons_why rep_tc $$ suggestion)
885 | not (null con_whys) = Just (vcat con_whys $$ suggestion)
886 | otherwise = Nothing
888 suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
889 data_cons = tyConDataCons rep_tc
890 con_whys = mapCatMaybes check_con data_cons
892 check_con :: DataCon -> Maybe SDoc
894 | isVanillaDataCon con
895 , all isTauTy (dataConOrigArgTys con) = Nothing
896 | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
898 no_cons_why :: TyCon -> SDoc
899 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
900 ptext (sLit "has no data constructors")
902 cond_enumOrProduct :: Condition
903 cond_enumOrProduct = cond_isEnumeration `orCond`
904 (cond_isProduct `andCond` cond_noUnliftedArgs)
906 cond_noUnliftedArgs :: Condition
907 -- For some classes (eg Eq, Ord) we allow unlifted arg types
908 -- by generating specilaised code. For others (eg Data) we don't.
909 cond_noUnliftedArgs (_, tc)
910 | null bad_cons = Nothing
911 | otherwise = Just why
913 bad_cons = [ con | con <- tyConDataCons tc
914 , any isUnLiftedType (dataConOrigArgTys con) ]
915 why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
917 cond_isEnumeration :: Condition
918 cond_isEnumeration (_, rep_tc)
919 | isEnumerationTyCon rep_tc = Nothing
920 | otherwise = Just why
922 why = sep [ quotes (pprSourceTyCon rep_tc) <+>
923 ptext (sLit "is not an enumeration type")
924 , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
925 -- See Note [Enumeration types] in TyCon
927 cond_isProduct :: Condition
928 cond_isProduct (_, rep_tc)
929 | isProductTyCon rep_tc = Nothing
930 | otherwise = Just why
932 why = quotes (pprSourceTyCon rep_tc) <+>
933 ptext (sLit "does not have precisely one constructor")
935 cond_typeableOK :: Condition
936 -- OK for Typeable class
937 -- Currently: (a) args all of kind *
938 -- (b) 7 or fewer args
939 cond_typeableOK (_, tc)
940 | tyConArity tc > 7 = Just too_many
941 | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc))
943 | otherwise = Nothing
945 too_many = quotes (pprSourceTyCon tc) <+>
946 ptext (sLit "has too many arguments")
947 bad_kind = quotes (pprSourceTyCon tc) <+>
948 ptext (sLit "has arguments of kind other than `*'")
950 functorLikeClassKeys :: [Unique]
951 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
953 cond_functorOK :: Bool -> Condition
954 -- OK for Functor/Foldable/Traversable class
955 -- Currently: (a) at least one argument
956 -- (b) don't use argument contravariantly
957 -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
958 -- (d) optionally: don't use function types
959 -- (e) no "stupid context" on data type
960 cond_functorOK allowFunctions (_, rep_tc)
962 = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
963 <+> ptext (sLit "has no parameters"))
965 | not (null bad_stupid_theta)
966 = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
967 <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
970 = msum (map check_con data_cons) -- msum picks the first 'Just', if any
972 tc_tvs = tyConTyVars rep_tc
973 Just (_, last_tv) = snocView tc_tvs
974 bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc)
975 is_bad pred = last_tv `elemVarSet` tyVarsOfPred pred
977 data_cons = tyConDataCons rep_tc
978 check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
980 check_vanilla :: DataCon -> Maybe SDoc
981 check_vanilla con | isVanillaDataCon con = Nothing
982 | otherwise = Just (badCon con existential)
984 ft_check :: DataCon -> FFoldType (Maybe SDoc)
985 ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
986 , ft_co_var = Just (badCon con covariant)
987 , ft_fun = \x y -> if allowFunctions then x `mplus` y
988 else Just (badCon con functions)
989 , ft_tup = \_ xs -> msum xs
990 , ft_ty_app = \_ x -> x
991 , ft_bad_app = Just (badCon con wrong_arg)
992 , ft_forall = \_ x -> x }
994 existential = ptext (sLit "has existential arguments")
995 covariant = ptext (sLit "uses the type variable in a function argument")
996 functions = ptext (sLit "contains function types")
997 wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
999 checkFlag :: ExtensionFlag -> Condition
1000 checkFlag flag (dflags, _)
1001 | xopt flag dflags = Nothing
1002 | otherwise = Just why
1004 why = ptext (sLit "You need -X") <> text flag_str
1005 <+> ptext (sLit "to derive an instance for this class")
1006 flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
1008 other -> pprPanic "checkFlag" (ppr other)
1010 std_class_via_iso :: Class -> Bool
1011 -- These standard classes can be derived for a newtype
1012 -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
1013 -- because giving so gives the same results as generating the boilerplate
1014 std_class_via_iso clas
1015 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
1016 -- Not Read/Show because they respect the type
1017 -- Not Enum, because newtypes are never in Enum
1020 non_iso_class :: Class -> Bool
1021 -- *Never* derive Read,Show,Typeable,Data by isomorphism,
1022 -- even with -XGeneralizedNewtypeDeriving
1024 = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
1027 typeableClassKeys :: [Unique]
1028 typeableClassKeys = map getUnique typeableClassNames
1030 new_dfun_name :: Class -> TyCon -> TcM Name
1031 new_dfun_name clas tycon -- Just a simple wrapper
1032 = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon
1033 ; newDFunName clas [mkTyConApp tycon []] loc }
1034 -- The type passed to newDFunName is only used to generate
1035 -- a suitable string; hence the empty type arg list
1037 badCon :: DataCon -> SDoc -> SDoc
1038 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1041 Note [Superclasses of derived instance]
1042 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1043 In general, a derived instance decl needs the superclasses of the derived
1044 class too. So if we have
1045 data T a = ...deriving( Ord )
1046 then the initial context for Ord (T a) should include Eq (T a). Often this is
1047 redundant; we'll also generate an Ord constraint for each constructor argument,
1048 and that will probably generate enough constraints to make the Eq (T a) constraint
1049 be satisfied too. But not always; consider:
1055 data T a = MkT (S a) deriving( Ord )
1056 instance Num a => Eq (T a)
1058 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1060 data T a = MkT deriving( Data, Typeable )
1061 Here there *is* no argument field, but we must nevertheless generate
1062 a context for the Data instances:
1063 instance Typable a => Data (T a) where ...
1066 %************************************************************************
1070 %************************************************************************
1073 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1074 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1076 -> TcRn EarlyDerivSpec
1077 mkNewTypeEqn orig dflags tvs
1078 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1079 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1080 | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1081 = do { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1082 ; dfun_name <- new_dfun_name cls tycon
1083 ; loc <- getSrcSpanM
1084 ; let spec = DS { ds_loc = loc, ds_orig = orig
1085 , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
1086 , ds_cls = cls, ds_tys = inst_tys
1087 , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1088 , ds_theta = mtheta `orElse` all_preds
1089 , ds_newtype = True }
1090 ; return (if isJust mtheta then Right spec
1094 = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1095 CanDerive -> go_for_it -- Use the standard H98 method
1096 DerivableClassError msg -- Error with standard class
1097 | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
1098 | otherwise -> bale_out msg
1099 NonDerivableClass -- Must use newtype deriving
1100 | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
1101 | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1102 | otherwise -> bale_out non_std
1104 newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1105 go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1106 bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1108 non_std = nonStdErr cls
1109 suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1111 -- Here is the plan for newtype derivings. We see
1112 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1113 -- where t is a type,
1114 -- ak+1...an is a suffix of a1..an, and are all tyars
1115 -- ak+1...an do not occur free in t, nor in the s1..sm
1116 -- (C s1 ... sm) is a *partial applications* of class C
1117 -- with the last parameter missing
1118 -- (T a1 .. ak) matches the kind of C's last argument
1119 -- (and hence so does t)
1120 -- The latter kind-check has been done by deriveTyData already,
1121 -- and tc_args are already trimmed
1123 -- We generate the instance
1124 -- instance forall ({a1..ak} u fvs(s1..sm)).
1125 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
1126 -- where T a1...ap is the partial application of
1127 -- the LHS of the correct kind and p >= k
1129 -- NB: the variables below are:
1130 -- tc_tvs = [a1, ..., an]
1131 -- tyvars_to_keep = [a1, ..., ak]
1132 -- rep_ty = t ak .. an
1133 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
1134 -- tys = [s1, ..., sm]
1137 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1138 -- We generate the instance
1139 -- instance Monad (ST s) => Monad (T s) where
1141 nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1142 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1143 -- eta-reduces the representation type, so we know that
1145 -- That's convenient here, because we may have to apply
1146 -- it to fewer than its original complement of arguments
1148 -- Note [Newtype representation]
1149 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150 -- Need newTyConRhs (*not* a recursive representation finder)
1151 -- to get the representation type. For example
1152 -- newtype B = MkB Int
1153 -- newtype A = MkA B deriving( Num )
1154 -- We want the Num instance of B, *not* the Num instance of Int,
1155 -- when making the Num instance of A!
1156 rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1157 rep_tys = cls_tys ++ [rep_inst_ty]
1158 rep_pred = mkClassPred cls rep_tys
1159 -- rep_pred is the representation dictionary, from where
1160 -- we are gong to get all the methods for the newtype
1164 -- Next we figure out what superclass dictionaries to use
1165 -- See Note [Newtype deriving superclasses] above
1167 cls_tyvars = classTyVars cls
1168 dfun_tvs = tyVarsOfTypes inst_tys
1169 inst_ty = mkTyConApp tycon tc_args
1170 inst_tys = cls_tys ++ [inst_ty]
1171 sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1174 -- If there are no tyvars, there's no need
1175 -- to abstract over the dictionaries we need
1176 -- Example: newtype T = MkT Int deriving( C )
1177 -- We get the derived instance
1180 -- instance C Int => C T
1181 all_preds = rep_pred : sc_theta -- NB: rep_pred comes first
1183 -------------------------------------------------------------------
1184 -- Figuring out whether we can only do this newtype-deriving thing
1186 can_derive_via_isomorphism
1187 = not (non_iso_class cls)
1191 -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
1193 arity_ok = length cls_tys + 1 == classArity cls
1194 -- Well kinded; eg not: newtype T ... deriving( ST )
1195 -- because ST needs *2* type params
1197 -- Check that eta reduction is OK
1198 eta_ok = nt_eta_arity <= length rep_tc_args
1199 -- The newtype can be eta-reduced to match the number
1200 -- of type argument actually supplied
1201 -- newtype T a b = MkT (S [a] b) deriving( Monad )
1202 -- Here the 'b' must be the same in the rep type (S [a] b)
1203 -- And the [a] must not mention 'b'. That's all handled
1206 ats_ok = null (classATs cls)
1207 -- No associated types for the class, because we don't
1208 -- currently generate type 'instance' decls; and cannot do
1209 -- so for 'data' instance decls
1212 = vcat [ ppUnless arity_ok arity_msg
1213 , ppUnless eta_ok eta_msg
1214 , ppUnless ats_ok ats_msg ]
1215 arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1216 eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
1217 ats_msg = ptext (sLit "the class has associated types")
1220 Note [Recursive newtypes]
1221 ~~~~~~~~~~~~~~~~~~~~~~~~~
1222 Newtype deriving works fine, even if the newtype is recursive.
1223 e.g. newtype S1 = S1 [T1 ()]
1224 newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1225 Remember, too, that type families are curretly (conservatively) given
1226 a recursive flag, so this also allows newtype deriving to work
1229 We used to exclude recursive types, because we had a rather simple
1230 minded way of generating the instance decl:
1232 instance Eq [A] => Eq A -- Makes typechecker loop!
1233 But now we require a simple context, so it's ok.
1236 %************************************************************************
1238 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1240 %************************************************************************
1242 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1243 terms, which is the final correct RHS for the corresponding original
1247 Each (k,TyVarTy tv) in a solution constrains only a type
1251 The (k,TyVarTy tv) pairs in a solution are canonically
1252 ordered by sorting on type varible, tv, (major key) and then class, k,
1257 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1259 inferInstanceContexts _ [] = return []
1261 inferInstanceContexts oflag infer_specs
1262 = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1263 ; iterate_deriv 1 initial_solutions }
1265 ------------------------------------------------------------------
1266 -- The initial solutions for the equations claim that each
1267 -- instance has an empty context; this solution is certainly
1268 -- in canonical form.
1269 initial_solutions :: [ThetaType]
1270 initial_solutions = [ [] | _ <- infer_specs ]
1272 ------------------------------------------------------------------
1273 -- iterate_deriv calculates the next batch of solutions,
1274 -- compares it with the current one; finishes if they are the
1275 -- same, otherwise recurses with the new solutions.
1276 -- It fails if any iteration fails
1277 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1278 iterate_deriv n current_solns
1279 | n > 20 -- Looks as if we are in an infinite loop
1280 -- This can happen if we have -XUndecidableInstances
1281 -- (See TcSimplify.tcSimplifyDeriv.)
1282 = pprPanic "solveDerivEqns: probable loop"
1283 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1285 = do { -- Extend the inst info from the explicit instance decls
1286 -- with the current set of solutions, and simplify each RHS
1287 let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1288 current_solns infer_specs
1289 ; new_solns <- checkNoErrs $
1290 extendLocalInstEnv inst_specs $
1291 mapM gen_soln infer_specs
1293 ; if (current_solns == new_solns) then
1294 return [ spec { ds_theta = soln }
1295 | (spec, soln) <- zip infer_specs current_solns ]
1297 iterate_deriv (n+1) new_solns }
1299 ------------------------------------------------------------------
1300 gen_soln :: DerivSpec -> TcM [PredType]
1301 gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1302 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1304 addErrCtxt (derivInstCtxt clas inst_tys) $
1305 do { -- Check for a bizarre corner case, when the derived instance decl should
1306 -- have form instance C a b => D (T a) where ...
1307 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1308 -- of problems; in particular, it's hard to compare solutions for
1309 -- equality when finding the fixpoint. Moreover, simplifyDeriv
1310 -- has an assert failure because it finds a TyVar when it expects
1311 -- only TcTyVars. So I just rule it out for now. I'm not
1312 -- even sure how it can arise.
1314 ; let tv_set = mkVarSet tyvars
1315 weird_preds = [pred | pred <- deriv_rhs
1316 , not (tyVarsOfPred pred `subVarSet` tv_set)]
1317 ; mapM_ (addErrTc . badDerivedPred) weird_preds
1319 ; theta <- simplifyDeriv orig tyvars deriv_rhs
1320 -- checkValidInstance tyvars theta clas inst_tys
1321 -- Not necessary; see Note [Exotic derived instance contexts]
1324 ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1325 -- Claim: the result instance declaration is guaranteed valid
1326 -- Hence no need to call:
1327 -- checkValidInstance tyvars theta clas inst_tys
1328 ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
1330 ------------------------------------------------------------------
1331 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1332 mkInstance overlap_flag theta
1333 (DS { ds_name = dfun_name
1334 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1335 = mkLocalInstance dfun overlap_flag
1337 dfun = mkDictFunId dfun_name tyvars theta clas tys
1340 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1341 -- Add new locally-defined instances; don't bother to check
1342 -- for functional dependency errors -- that'll happen in TcInstDcls
1343 extendLocalInstEnv dfuns thing_inside
1344 = do { env <- getGblEnv
1345 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1346 env' = env { tcg_inst_env = inst_env' }
1347 ; setGblEnv env' thing_inside }
1351 %************************************************************************
1353 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1355 %************************************************************************
1357 After all the trouble to figure out the required context for the
1358 derived instance declarations, all that's left is to chug along to
1359 produce them. They will then be shoved into @tcInstDecls2@, which
1360 will do all its usual business.
1362 There are lots of possibilities for code to generate. Here are
1363 various general remarks.
1368 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1369 ``you-couldn't-do-better-by-hand'' efficient.
1372 Deriving @Show@---also pretty common--- should also be reasonable good code.
1375 Deriving for the other classes isn't that common or that big a deal.
1382 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1385 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1388 We {\em normally} generate code only for the non-defaulted methods;
1389 there are some exceptions for @Eq@ and (especially) @Ord@...
1392 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1393 constructor's numeric (@Int#@) tag. These are generated by
1394 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1395 these is around is given by @hasCon2TagFun@.
1397 The examples under the different sections below will make this
1401 Much less often (really just for deriving @Ix@), we use a
1402 @_tag2con_<tycon>@ function. See the examples.
1405 We use the renamer!!! Reason: we're supposed to be
1406 producing @LHsBinds Name@ for the methods, but that means
1407 producing correctly-uniquified code on the fly. This is entirely
1408 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1409 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1410 the renamer. What a great hack!
1414 -- Generate the InstInfo for the required instance paired with the
1415 -- *representation* tycon for that instance,
1416 -- plus any auxiliary bindings required
1418 -- Representation tycons differ from the tycon in the instance signature in
1419 -- case of instances for indexed families.
1421 genInst :: Bool -- True <=> standalone deriving
1423 -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1424 genInst standalone_deriv oflag
1425 spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1426 , ds_theta = theta, ds_newtype = is_newtype
1427 , ds_name = name, ds_cls = clas })
1429 = return (InstInfo { iSpec = inst_spec
1430 , iBinds = NewTypeDerived co rep_tycon }, [])
1433 = do { fix_env <- getFixityEnv
1434 ; let loc = getSrcSpan name
1435 (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1436 -- In case of a family instance, we need to use the representation
1437 -- tycon (after all, it has the data constructors)
1439 ; return (InstInfo { iSpec = inst_spec
1440 , iBinds = VanillaInst meth_binds [] standalone_deriv }
1443 inst_spec = mkInstance oflag theta spec
1444 co1 = case tyConFamilyCoercion_maybe rep_tycon of
1445 Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1447 -- Not a family => rep_tycon = main tycon
1448 co2 = case newTyConCo_maybe rep_tycon of
1449 Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1450 Nothing -> id_co -- The newtype is transparent; no need for a cast
1451 co = co1 `mkTransCoI` co2
1452 id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
1454 -- Example: newtype instance N [a] = N1 (Tree a)
1455 -- deriving instance Eq b => Eq (N [(b,b)])
1456 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1457 -- When dealing with the deriving clause
1458 -- co1 : N [(b,b)] ~ R1:N (b,b)
1459 -- co2 : R1:N (b,b) ~ Tree (b,b)
1460 -- co : N [(b,b)] ~ Tree (b,b)
1462 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1463 genDerivBinds loc fix_env clas tycon
1464 | className clas `elem` typeableClassNames
1465 = (gen_Typeable_binds loc tycon, [])
1468 = case assocMaybe gen_list (getUnique clas) of
1469 Just gen_fn -> gen_fn loc tycon
1470 Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1472 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1473 gen_list = [(eqClassKey, gen_Eq_binds)
1474 ,(ordClassKey, gen_Ord_binds)
1475 ,(enumClassKey, gen_Enum_binds)
1476 ,(boundedClassKey, gen_Bounded_binds)
1477 ,(ixClassKey, gen_Ix_binds)
1478 ,(showClassKey, gen_Show_binds fix_env)
1479 ,(readClassKey, gen_Read_binds fix_env)
1480 ,(dataClassKey, gen_Data_binds)
1481 ,(functorClassKey, gen_Functor_binds)
1482 ,(foldableClassKey, gen_Foldable_binds)
1483 ,(traversableClassKey, gen_Traversable_binds)
1486 -- Generate the binds for the generic representation
1487 genGenericRepBinds :: Bool -> [LTyClDecl Name]
1488 -> TcM [([(InstInfo RdrName, DerivAuxBinds)]
1489 , MetaTyCons, TyCon)]
1490 genGenericRepBinds isBoot tyclDecls
1491 | isBoot = return []
1493 allTyDecls <- mapM tcLookupTyCon [ tcdName d | L _ d <- tyclDecls
1495 let tyDecls = filter tyConHasGenerics allTyDecls
1496 inst1 <- mapM genGenericRepBind tyDecls
1497 let (repInsts, metaTyCons, repTys) = unzip3 inst1
1498 metaInsts <- ASSERT (length tyDecls == length metaTyCons)
1499 mapM genDtMeta (zip tyDecls metaTyCons)
1500 return (ASSERT (length inst1 == length metaInsts)
1502 | ((ri, ms, rt), mi) <- zip inst1 metaInsts ])
1504 genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds)
1505 , MetaTyCons, TyCon)
1506 genGenericRepBind tc =
1507 do clas <- tcLookupClass rep0ClassName
1508 uniqS <- newUniqueSupply
1509 dfun_name <- new_dfun_name clas tc
1511 -- Uniques for everyone
1512 (uniqD:uniqs) = uniqsFromSupply uniqS
1513 (uniqsC,us) = splitAt (length tc_cons) uniqs
1514 uniqsS :: [[Unique]] -- Unique supply for the S datatypes
1515 uniqsS = mkUniqsS tc_arits us
1517 mkUniqsS (n:t) us = case splitAt n us of
1518 (us1,us2) -> us1 : mkUniqsS t us2
1520 tc_name = tyConName tc
1521 tc_cons = tyConDataCons tc
1522 tc_arits = map dataConSourceArity tc_cons
1524 tc_occ = nameOccName tc_name
1525 d_occ = mkGenD tc_occ
1526 c_occ m = mkGenC tc_occ m
1527 s_occ m n = mkGenS tc_occ m n
1528 mod_name = nameModule (tyConName tc)
1529 d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
1530 c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
1531 | (u,m) <- zip uniqsC [0..] ]
1532 s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
1533 | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
1534 tvs = tyConTyVars tc
1535 tc_ty = mkTyConApp tc (mkTyVarTys tvs)
1537 mkTyCon name = ASSERT( isExternalName name )
1538 buildAlgTyCon name [] [] mkAbstractTyConRhs
1539 NonRecursive False False NoParentTyCon Nothing
1541 metaDTyCon <- mkTyCon d_name
1542 metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
1543 metaSTyCons <- mapM sequence
1545 | s_name <- s_namesC ] | s_namesC <- s_names ]
1547 let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
1549 rep0_tycon <- tc_mkRep0TyCon tc metaDts
1552 mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds }
1553 , [ {- No DerivAuxBinds -} ])
1554 inst = mkLocalInstance dfun NoOverlap
1555 binds = VanillaInst (mkBindsRep0 tc) [] False
1557 dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
1558 return (mkInstRep0, metaDts, rep0_tycon)
1560 genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
1561 genDtMeta (tc,metaDts) =
1562 do dClas <- tcLookupClass datatypeClassName
1563 d_dfun_name <- new_dfun_name dClas tc
1564 cClas <- tcLookupClass constructorClassName
1565 c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
1566 sClas <- tcLookupClass selectorClassName
1567 s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
1569 | x <- metaS metaDts ])
1570 fix_env <- getFixityEnv
1573 (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
1576 d_metaTycon = metaD metaDts
1577 d_inst = mkLocalInstance d_dfun NoOverlap
1578 d_binds = VanillaInst dBinds [] False
1579 d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
1580 [ mkTyConTy d_metaTycon ]
1581 d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
1584 c_metaTycons = metaC metaDts
1585 c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap
1586 | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
1587 c_binds = [ VanillaInst c [] False | c <- cBinds ]
1588 c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
1590 c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, [])
1591 | (is,bs) <- myZip1 c_insts c_binds ]
1594 s_metaTycons = metaS metaDts
1595 s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap))
1596 (myZip2 s_metaTycons s_dfun_names)
1597 s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
1598 s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
1600 s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
1601 (myZip2 s_insts s_binds)
1603 myZip1 :: [a] -> [b] -> [(a,b)]
1604 myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
1606 myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
1608 ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
1609 [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
1611 return (d_mkInst : c_mkInst ++ concat s_mkInst)
1615 %************************************************************************
1617 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1619 %************************************************************************
1622 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1623 derivingKindErr tc cls cls_tys cls_kind
1624 = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1625 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1626 2 (ptext (sLit "Class") <+> quotes (ppr cls)
1627 <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1629 derivingEtaErr :: Class -> [Type] -> Type -> Message
1630 derivingEtaErr cls cls_tys inst_ty
1631 = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1632 nest 2 (ptext (sLit "instance (...) =>")
1633 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1635 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1636 typeFamilyPapErr tc cls cls_tys inst_ty
1637 = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1638 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1640 derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message
1641 derivingThingErr newtype_deriving clas tys ty why
1642 = sep [(hang (ptext (sLit "Can't make a derived instance of"))
1643 2 (quotes (ppr pred))
1644 $$ nest 2 extra) <> colon,
1647 extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
1649 pred = mkClassPred clas (tys ++ [ty])
1651 derivingHiddenErr :: TyCon -> SDoc
1652 derivingHiddenErr tc
1653 = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1654 2 (ptext (sLit "so you cannot derive an instance for it"))
1656 standaloneCtxt :: LHsType Name -> SDoc
1657 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1660 derivInstCtxt :: Class -> [Type] -> Message
1661 derivInstCtxt clas inst_tys
1662 = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1664 badDerivedPred :: PredType -> Message
1666 = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1667 ptext (sLit "type variables that are not data type parameters"),
1668 nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]