- = 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
+ CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+ NonDerivableClass -> bale_out (nonStdErr cls)
+ DerivableClassError msg -> bale_out msg
+ where
+ bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg)
+
+mk_data_eqn, mk_typeable_eqn
+ :: InstOrigin -> [TyVar] -> Class
+ -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
+ -> TcM EarlyDerivSpec
+mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+ | getName cls `elem` typeableClassNames
+ = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+
+ | otherwise
+ = do { dfun_name <- new_dfun_name cls tycon
+ ; loc <- getSrcSpanM
+ ; let ordinary_constraints_simple
+ = [ mkClassPred cls [arg_ty]
+ | data_con <- tyConDataCons rep_tc,
+ arg_ty <- ASSERT( isVanillaDataCon data_con )
+ dataConInstOrigArgTys data_con rep_tc_args,
+ not (isUnLiftedType arg_ty) ]
+ -- No constraints for unlifted types
+ -- Where they are legal we generate specilised function calls
+
+ -- constraints on all subtypes for classes like Functor
+ ordinary_constraints_deep
+ = [ mkClassPred cls [deept_ty]
+ | data_con <- tyConDataCons rep_tc,
+ arg_ty <- ASSERT( isVanillaDataCon data_con )
+ dataConInstOrigArgTys data_con (rep_tc_args++[mkTyVarTy dummy_ty]),
+ deept_ty <- deepSubtypesContaining dummy_ty arg_ty,
+ not (isUnLiftedType deept_ty) ]
+ where dummy_ty = last (tyConTyVars tycon) -- don't substitute the last var, this might not be a good idea
+
+ ordinary_constraints
+ | getUnique cls == functorClassKey = ordinary_constraints_deep
+ | getUnique cls == foldableClassKey = ordinary_constraints_deep
+ | getUnique cls == traversableClassKey = ordinary_constraints_deep
+ | otherwise = ordinary_constraints_simple
+
+ -- See Note [Superclasses of derived instance]
+ sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+ (classSCTheta cls)
+ inst_tys = [mkTyConApp tycon tc_args]
+
+ nonfree_tycon_vars = dropTail (classArity cls) (tyConTyVars rep_tc)
+ stupid_subst = zipTopTvSubst nonfree_tycon_vars rep_tc_args
+ stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
+
+ all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
+
+ spec = DS { ds_loc = loc, ds_orig = orig
+ , ds_name = dfun_name, ds_tvs = tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_tc = rep_tc, ds_tc_args = rep_tc_args
+ , ds_theta = mtheta `orElse` all_constraints
+ , ds_newtype = False }
+
+ ; return (if isJust mtheta then Right spec -- Specified context
+ else Left spec) } -- Infer context
+
+mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+ -- The Typeable class is special in several ways