- ; ASSERT( isSingleton theta ) -- Always the case for NewTypeDerived
- rep_dict <- newDict origin (head theta)
-
- ; let rep_dict_id = instToId rep_dict
- cast =
- co_fn = CoTyLams tvs <.> CoLams [rep_dict_id] <.> ExprCoFn cast
-
- ; return (unitBag (VarBind dfun_id (HsCoerce co_fn (HsVar rep_dict_id))))
-
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
- avail_insts op_items (NewTypeDerived rep_tys)
- = getInstLoc origin `thenM` \ inst_loc ->
- mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
-
- tcSimplifyCheck
- (ptext SLIT("newtype derived instance"))
- inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds ->
-
- -- I don't think we have to do the checkSigTyVars thing
-
- returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)
-
+ ; dicts <- newDictBndrs inst_loc theta
+ ; uniqs <- newUniqueSupply
+ ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
+ ; this_dict <- newDictBndr inst_loc (mkClassPred cls rep_tys)
+ ; let (rep_dict_id:sc_dict_ids)
+ | null dicts = [instToId this_dict]
+ | otherwise = map instToId dicts
+
+ -- (Here, we are relying on the order of dictionary
+ -- arguments built by NewTypeDerived in TcDeriv.)
+
+ wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids)
+
+ -- we need to find the kind that this class applies to
+ -- and drop trailing tvs appropriately
+ cls_kind = tyVarKind (head (reverse (tyConTyVars cls_tycon)))
+ the_tvs = drop_tail (length (fst (splitFunTys cls_kind))) tvs
+
+ coerced_rep_dict = mkHsCoerce (co_fn the_tvs cls_tycon cls_inst_tys) (HsVar rep_dict_id)
+
+ body | null sc_dict_ids = coerced_rep_dict
+ | otherwise = HsCase (noLoc coerced_rep_dict) $
+ MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
+ in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
+
+ the_match = mkSimpleMatch [noLoc the_pat] the_rhs
+ the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
+
+ (uniqs1, uniqs2) = splitUniqSupply uniqs
+
+ op_ids = zipWith (mkSysLocal FSLIT("op"))
+ (uniqsFromSupply uniqs1) op_tys
+
+ dict_ids = zipWith (mkSysLocal FSLIT("dict"))
+ (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
+
+ the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+ pat_dicts = dict_ids,
+ pat_binds = emptyLHsBinds,
+ pat_args = PrefixCon (map nlVarPat op_ids),
+ pat_ty = in_dict_ty}
+
+ cls_data_con = classDataCon cls
+ cls_tycon = dataConTyCon cls_data_con
+ cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
+
+ n_dict_args = if length dicts == 0 then 0 else length dicts - 1
+ op_tys = drop n_dict_args cls_arg_tys
+
+ dict = mkHsCoerce wrap_fn body
+ ; return (unitBag (noLoc $ VarBind dfun_id (noLoc dict))) }