+
+ -----------------------
+ -- make_wrapper
+ -- We distinguish two cases:
+ -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant,
+ -- and the new dict can just be a constant
+ -- (mb_preds = Just preds)
+ -- (b) there are tyvars, so we must make a dict *fun*
+ -- (mb_preds = Nothing)
+ -- See the defn of NewTypeDerived for the meaning of mb_preds
+ make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
+ = ASSERT( null tvs && null theta )
+ do { dicts <- newDictBndrs inst_loc preds
+ ; sc_binds <- addErrCtxt superClassCtxt $
+ tcSimplifySuperClasses inst_loc [] dicts
+ -- Use tcSimplifySuperClasses to avoid creating loops, for the
+ -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
+ ; return (map instToId dicts, idHsWrapper, sc_binds) }
+
+ make_wrapper inst_loc tvs theta Nothing -- Case (b)
+ = do { dicts <- newDictBndrs inst_loc theta
+ ; let dict_ids = map instToId dicts
+ ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) }
+
+ -----------------------
+ -- make_coercion
+ -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
+ -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
+ -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
+ -- where rep_ty is the (eta-reduced) type rep of T
+ -- So we just replace T with CoT, and insert a 'sym'
+ -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
+
+ make_coercion cls_tycon cls_inst_tys
+ | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys
+ , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail
+ , Just co_con <- newTyConCo_maybe tycon
+ , let co = mkSymCoercion (mkTyConApp co_con tc_args)
+ = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
+ | otherwise -- The newtype is transparent; no need for a cast
+ = idHsWrapper
+
+ -----------------------
+ -- make_body
+ -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs
+ -- (a) no superclasses; then we can just use the coerced dict
+ -- (b) one or more superclasses; then new need to do the unpack/repack
+
+ make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
+ | null sc_dict_ids -- Case (a)
+ = return coerced_rep_dict
+ | otherwise -- Case (b)
+ = do { op_ids <- newSysLocalIds FSLIT("op") op_tys
+ ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
+ ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+ pat_dicts = dummy_sc_dict_ids,
+ pat_binds = emptyLHsBinds,
+ pat_args = PrefixCon (map nlVarPat op_ids),
+ pat_ty = pat_ty}
+ the_match = mkSimpleMatch [noLoc the_pat] the_rhs
+ the_rhs = mkHsConApp cls_data_con cls_inst_tys $
+ map HsVar (sc_dict_ids ++ op_ids)
+
+ -- Warning: this HsCase scrutinises a value with a PredTy, which is
+ -- never otherwise seen in Haskell source code. It'd be
+ -- nicer to generate Core directly!
+ ; return (HsCase (noLoc coerced_rep_dict) $
+ MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
+ where
+ pat_ty = mkTyConApp cls_tycon cls_inst_tys
+ cls_data_con = head (tyConDataCons cls_tycon)
+ cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
+ op_tys = dropList sc_dict_ids cls_arg_tys