+makeDerivEqns tycl_decls deriv_decls
+ = do { eqns1 <- mapM deriveTyData $
+ [ (p,d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- tycl_decls
+ , p <- preds ]
+ ; eqns2 <- mapM deriveStandalone deriv_decls
+ ; return ([eqn | (Just eqn, _) <- eqns1 ++ eqns2],
+ [inst | (_, Just inst) <- eqns1 ++ eqns2]) }
+
+------------------------------------------------------------------
+deriveStandalone :: LDerivDecl Name -> TcM (Maybe DerivEqn, Maybe InstInfo)
+-- Standalone deriving declarations
+-- e.g. derive instance Show T
+-- Rather like tcLocalInstDecl
+deriveStandalone (L loc (DerivDecl deriv_ty))
+ = setSrcSpan loc $
+ addErrCtxt (standaloneCtxt deriv_ty) $
+ do { (tvs, theta, tau) <- tcHsInstHead deriv_ty
+ ; (cls, inst_tys) <- checkValidInstHead tau
+ ; let cls_tys = take (length inst_tys - 1) inst_tys
+ inst_ty = last inst_tys
+
+ ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty }
+
+------------------------------------------------------------------
+deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
+deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name,
+ tcdTyVars = tv_names,
+ tcdTyPats = ty_pats }))
+ = setSrcSpan loc $
+ tcAddDeclCtxt decl $
+ do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
+ hs_app = nlHsTyConApp tycon_name hs_ty_args
+ -- We get kinding info for the tyvars by typechecking (T a b)
+ -- Hence forming a tycon application and then dis-assembling it
+ ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
+ ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
+ -- the type variables for the type constructor
+ do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
+ -- The "deriv_pred" is a LHsType to take account of the fact that for
+ -- newtype deriving we allow deriving (forall a. C [a]).
+ ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app } }
+deriveTyData (deriv_pred, other_decl)
+ = panic "derivTyData" -- Caller ensures that only TyData can happen
+
+------------------------------------------------------------------
+mkEqnHelp orig tvs cls cls_tys tc_app
+ | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
+ = do { -- Make tc_app saturated, because that's what the
+ -- mkDataTypeEqn things expect
+ -- It might not be saturated in the standalone deriving case
+ -- derive instance Monad (T a)
+ let extra_tvs = dropList tc_args (tyConTyVars tycon)
+ full_tc_args = tc_args ++ mkTyVarTys extra_tvs
+ full_tvs = tvs ++ extra_tvs
+
+ ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
+
+ ; gla_exts <- doptM Opt_GlasgowExts
+ ; overlap_flag <- getOverlapFlag
+
+ -- Be careful to test rep_tc here: in the case of families, we want
+ -- to check the instance tycon, not the family tycon
+ ; if isDataTyCon rep_tc then
+ mkDataTypeEqn orig gla_exts full_tvs cls cls_tys
+ tycon full_tc_args rep_tc rep_tc_args
+ else
+ mkNewTypeEqn orig gla_exts overlap_flag full_tvs cls cls_tys
+ tycon full_tc_args rep_tc rep_tc_args }
+ | otherwise
+ = baleOut (derivingThingErr cls cls_tys tc_app
+ (ptext SLIT("Last argument of the instance must be a type application")))
+
+baleOut err = addErrTc err >> returnM (Nothing, Nothing)
+\end{code}
+
+Auxiliary lookup wrapper which requires that looked up family instances are
+not type instances.
+
+\begin{code}
+tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
+tcLookupFamInstExact tycon tys
+ = do { result@(rep_tycon, rep_tys) <- tcLookupFamInst tycon tys
+ ; let { tvs = map (Type.getTyVar
+ "TcDeriv.tcLookupFamInstExact")
+ rep_tys
+ ; variable_only_subst = all Type.isTyVarTy rep_tys &&
+ sizeVarSet (mkVarSet tvs) == length tvs
+ -- renaming may have no repetitions
+ }
+ ; unless variable_only_subst $
+ famInstNotFound tycon tys [result]
+ ; return result
+ }
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Deriving data types
+%* *
+%************************************************************************
+
+\begin{code}
+mkDataTypeEqn orig gla_exts tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
+ | Just err <- checkSideConditions gla_exts cls cls_tys rep_tc
+ -- NB: pass the *representation* tycon to checkSideConditions
+ = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
+
+ | otherwise
+ = ASSERT( null cls_tys )
+ do { loc <- getSrcSpanM
+ ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args
+ ; return (Just eqn, Nothing) }
+
+mk_data_eqn :: SrcSpan -> InstOrigin -> [TyVar] -> Class
+ -> TyCon -> [TcType] -> TyCon -> [TcType] -> TcM DerivEqn
+mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args
+ | cls `hasKey` typeableClassKey
+ = -- The Typeable class is special in several ways
+ -- data T a b = ... deriving( Typeable )
+ -- gives
+ -- instance Typeable2 T where ...
+ -- Notice that:
+ -- 1. There are no constraints in the instance
+ -- 2. There are no type variables either
+ -- 3. The actual class we want to generate isn't necessarily
+ -- Typeable; it depends on the arity of the type
+ do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+ ; dfun_name <- new_dfun_name real_clas tycon
+ ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], []) }
+
+ | otherwise
+ = do { dfun_name <- new_dfun_name cls tycon
+ ; let ordinary_constraints
+ = [ mkClassPred cls [arg_ty]
+ | data_con <- tyConDataCons rep_tc,
+ arg_ty <- dataConInstOrigArgTys data_con rep_tc_args,
+ not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
+
+ tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
+ stupid_constraints = substTheta tiresome_subst (tyConStupidTheta rep_tc)
+ -- see note [Data decl contexts] above
+
+ ; return (loc, orig, dfun_name, tvs, cls, mkTyConApp tycon tc_args,
+ stupid_constraints ++ ordinary_constraints)
+ }
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for particular classes
+-- This is *apart* from the newtype-deriving mechanism
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
+
+checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
+checkSideConditions gla_exts cls cls_tys rep_tc
+ | notNull cls_tys
+ = Just ty_args_why -- e.g. deriving( Foo s )
+ | otherwise
+ = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
+ [] -> Just (non_std_why cls)
+ [cond] -> cond (gla_exts, rep_tc)
+ other -> pprPanic "checkSideConditions" (ppr cls)