Commit 25f84fa7 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactor, improve, and document the deriving mechanism

This patch does a fairly major clean-up of the code that implements 'deriving.

* The big changes are in TcDeriv, which is dramatically cleaned up.
  In particular, there is a clear split into
	a) inference of instance contexts for deriving clauses
	b) generation of the derived code, given a context 
  Step (a) is skipped for standalone instance decls, which 
  have an explicitly provided context.

* The handling of "taggery", which is cooperative between TcDeriv and
  TcGenDeriv, is cleaned up a lot

* I have added documentation for standalone deriving (which was 
  previously wrong).

* The Haskell report is vague on exactly when a deriving clause should
  succeed.  Prodded by Conal I have loosened the rules slightly, thereyb
  making drv015 work again, and documented the rules in the user manual.

I believe this patch validates ok (once I've update the test suite)
and can go into the 6.8 branch.
parent d9236c26
This diff is collapsed.
......@@ -635,30 +635,20 @@ iDFunId info = instanceDFunId (iSpec info)
data InstBindings
= VanillaInst -- The normal case
(LHsBinds Name) -- Bindings
(LHsBinds Name) -- Bindings for the instance methods
[LSig Name] -- User pragmas recorded for generating
-- specialised instances
| NewTypeDerived -- Used for deriving instances of newtypes, where the
-- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
(Maybe [PredType])
-- Nothing => The newtype-derived instance involves type variables,
-- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
-- Just (r:scs) => The newtype-defined instance has no type variables
-- so the dfun is just a constant, df :: Eq T
-- In this case we need to know waht the rep dict, r, and the
-- superclasses, scs, are. (In the Nothing case these are in the
-- dict fun's type.)
-- Invariant: these PredTypes have no free variables
-- NB: In both cases, the representation dict is the *first* dict.
pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
details (VanillaInst b _) = pprLHsBinds b
details (NewTypeDerived _) = text "Derived from the representation type"
details (VanillaInst b _) = pprLHsBinds b
details NewTypeDerived = text "Derived from the representation type"
simpleInstInfoClsTy :: InstInfo -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
......
......@@ -19,6 +19,8 @@ This is where we do all the grimy bindings' generation.
-- for details
module TcGenDeriv (
DerivAuxBind(..), DerivAuxBinds, isDupAux,
gen_Bounded_binds,
gen_Enum_binds,
gen_Eq_binds,
......@@ -28,11 +30,9 @@ module TcGenDeriv (
gen_Show_binds,
gen_Data_binds,
gen_Typeable_binds,
gen_tag_n_con_monobind,
con2tag_RDR, tag2con_RDR, maxtag_RDR,
genAuxBind,
TagThingWanted(..)
con2tag_RDR, tag2con_RDR, maxtag_RDR
) where
#include "HsVersions.h"
......@@ -62,15 +62,26 @@ import Bag
import Data.List ( partition, intersperse )
\end{code}
%************************************************************************
%* *
\subsection{Generating code, by derivable class}
%* *
%************************************************************************
\begin{code}
type DerivAuxBinds = [DerivAuxBind]
data DerivAuxBind -- Please add these auxiliary top-level bindings
= DerivAuxBind (LHsBind RdrName)
| GenCon2Tag TyCon -- The con2Tag for given TyCon
| GenTag2Con TyCon -- ...ditto tag2Con
| GenMaxTag TyCon -- ...and maxTag
isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2
isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2
isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1==tc2
isDupAux b1 b2 = False
\end{code}
%************************************************************************
%* *
\subsubsection{Generating @Eq@ instance declarations}
Eq instances
%* *
%************************************************************************
......@@ -143,33 +154,36 @@ instance ... Eq (Foo ...) where
\begin{code}
gen_Eq_binds :: TyCon -> LHsBinds RdrName
gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Eq_binds tycon
= let
tycon_loc = getSrcSpan tycon
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
| otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
rest
= if (null nullary_cons) then
case maybeTyConSingleCon tycon of
Just _ -> []
Nothing -> -- if cons don't match, then False
[([nlWildPat, nlWildPat], false_Expr)]
else -- calc. and compare the tags
[([a_Pat, b_Pat],
untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
in
listToBag [
mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
]
= (method_binds, aux_binds)
where
tycon_loc = getSrcSpan tycon
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
| otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
no_nullary_cons = null nullary_cons
rest | no_nullary_cons
= case maybeTyConSingleCon tycon of
Just _ -> []
Nothing -> -- if cons don't match, then False
[([nlWildPat, nlWildPat], false_Expr)]
| otherwise -- calc. and compare the tags
= [([a_Pat, b_Pat],
untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
aux_binds | no_nullary_cons = []
| otherwise = [GenCon2Tag tycon]
method_binds = listToBag [
mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
------------------------------------------------------------------
pats_etc data_con
= let
......@@ -193,7 +207,7 @@ gen_Eq_binds tycon
%************************************************************************
%* *
\subsubsection{Generating @Ord@ instance declarations}
Ord instances
%* *
%************************************************************************
......@@ -288,14 +302,17 @@ If there is only one constructor in the Data Type we don't need the WildCard Pat
JJQC-30-Nov-1997
\begin{code}
gen_Ord_binds :: TyCon -> LHsBinds RdrName
gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Ord_binds tycon
= unitBag compare -- `AndMonoBinds` compare
-- The default declaration in PrelBase handles this
= (unitBag compare, aux_binds)
-- `AndMonoBinds` compare
-- The default declaration in PrelBase handles this
where
tycon_loc = getSrcSpan tycon
--------------------------------------------------------------------
aux_binds | single_con_type = []
| otherwise = [GenCon2Tag tycon]
compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
......@@ -333,38 +350,37 @@ gen_Ord_binds tycon
else
[([nlWildPat, nlWildPat], default_rhs)])
where
pats_etc data_con
= ([con1_pat, con2_pat],
nested_compare_expr tys_needed as_needed bs_needed)
where
con1_pat = nlConVarPat data_con_RDR as_needed
con2_pat = nlConVarPat data_con_RDR bs_needed
default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
-- inexhaustive patterns
| otherwise = eqTag_Expr -- Some nullary constructors;
-- Tags are equal, no args => return EQ
pats_etc data_con
= ([con1_pat, con2_pat],
nested_compare_expr tys_needed as_needed bs_needed)
where
con1_pat = nlConVarPat data_con_RDR as_needed
con2_pat = nlConVarPat data_con_RDR bs_needed
data_con_RDR = getRdrName data_con
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
tys_needed = dataConOrigArgTys data_con
data_con_RDR = getRdrName data_con
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
tys_needed = dataConOrigArgTys data_con
nested_compare_expr [ty] [a] [b]
= careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
nested_compare_expr [ty] [a] [b]
= careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
nested_compare_expr (ty:tys) (a:as) (b:bs)
= let eq_expr = nested_compare_expr tys as bs
nested_compare_expr (ty:tys) (a:as) (b:bs)
= let eq_expr = nested_compare_expr tys as bs
in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
-- inexhaustive patterns
| otherwise = eqTag_Expr -- Some nullary constructors;
-- Tags are equal, no args => return EQ
\end{code}
%************************************************************************
%* *
\subsubsection{Generating @Enum@ instance declarations}
Enum instances
%* *
%************************************************************************
......@@ -404,18 +420,20 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
gen_Enum_binds :: TyCon -> LHsBinds RdrName
gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Enum_binds tycon
= listToBag [
succ_enum,
pred_enum,
to_enum,
enum_from,
enum_from_then,
from_enum
]
= (method_binds, aux_binds)
where
method_binds = listToBag [
succ_enum,
pred_enum,
to_enum,
enum_from,
enum_from_then,
from_enum
]
aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
tycon_loc = getSrcSpan tycon
occ_nm = getOccString tycon
......@@ -477,17 +495,18 @@ gen_Enum_binds tycon
%************************************************************************
%* *
\subsubsection{Generating @Bounded@ instance declarations}
Bounded instances
%* *
%************************************************************************
\begin{code}
gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Bounded_binds tycon
= if isEnumerationTyCon tycon then
listToBag [ min_bound_enum, max_bound_enum ]
else
ASSERT(isSingleton data_cons)
listToBag [ min_bound_1con, max_bound_1con ]
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], [])
| otherwise
= ASSERT(isSingleton data_cons)
(listToBag [ min_bound_1con, max_bound_1con ], [])
where
data_cons = tyConDataCons tycon
tycon_loc = getSrcSpan tycon
......@@ -512,7 +531,7 @@ gen_Bounded_binds tycon
%************************************************************************
%* *
\subsubsection{Generating @Ix@ instance declarations}
Ix instances
%* *
%************************************************************************
......@@ -569,12 +588,13 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
\begin{code}
gen_Ix_binds :: TyCon -> LHsBinds RdrName
gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Ix_binds tycon
= if isEnumerationTyCon tycon
then enum_ixes
else single_con_ixes
| isEnumerationTyCon tycon
= (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
| otherwise
= (single_con_ixes, [GenCon2Tag tycon])
where
tycon_loc = getSrcSpan tycon
......@@ -685,7 +705,7 @@ gen_Ix_binds tycon
%************************************************************************
%* *
\subsubsection{Generating @Read@ instance declarations}
Read instances
%* *
%************************************************************************
......@@ -728,10 +748,10 @@ instance Read T where
\begin{code}
gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Read_binds get_fixity tycon
= listToBag [read_prec, default_readlist, default_readlistprec]
= (listToBag [read_prec, default_readlist, default_readlistprec], [])
where
-----------------------------------------------------------------------
default_readlist
......@@ -853,7 +873,7 @@ gen_Read_binds get_fixity tycon
%************************************************************************
%* *
\subsubsection{Generating @Show@ instance declarations}
Show instances
%* *
%************************************************************************
......@@ -881,10 +901,10 @@ Example
-- the most tightly-binding operator
\begin{code}
gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Show_binds get_fixity tycon
= listToBag [shows_prec, show_list]
= (listToBag [shows_prec, show_list], [])
where
tycon_loc = getSrcSpan tycon
-----------------------------------------------------------------------
......@@ -1032,7 +1052,7 @@ mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
%************************************************************************
%* *
\subsection{Data}
Data instances
%* *
%************************************************************************
......@@ -1065,11 +1085,11 @@ we generate
gen_Data_binds :: FixityEnv
-> TyCon
-> (LHsBinds RdrName, -- The method bindings
LHsBinds RdrName) -- Auxiliary bindings
DerivAuxBinds) -- Auxiliary bindings
gen_Data_binds fix_env tycon
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
-- Auxiliary definitions: the data type and constructors
datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
DerivAuxBind datatype_bind : map mk_con_bind data_cons)
where
tycon_loc = getSrcSpan tycon
tycon_name = tyConName tycon
......@@ -1136,7 +1156,8 @@ gen_Data_binds fix_env tycon
------------ $cT1 etc
mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
mk_con_bind dc = mkVarBind
mk_con_bind dc = DerivAuxBind $
mkVarBind
tycon_loc
(mk_constr_name dc)
(nlHsApps mkConstr_RDR (constr_args dc))
......@@ -1183,16 +1204,12 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
\begin{code}
data TagThingWanted
= GenCon2Tag | GenTag2Con | GenMaxTag
genAuxBind :: DerivAuxBind -> LHsBind RdrName
gen_tag_n_con_monobind
:: ( RdrName, -- (proto)Name for the thing in question
TyCon, -- tycon in question
TagThingWanted)
-> LHsBind RdrName
genAuxBind (DerivAuxBind bind)
= bind
gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
genAuxBind (GenCon2Tag tycon)
| lots_of_constructors
= mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
......@@ -1200,6 +1217,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
= mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
where
rdr_name = con2tag_RDR tycon
tycon_loc = getSrcSpan tycon
tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
......@@ -1226,19 +1244,21 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
mk_stuff con = ([nlWildConPat con],
nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
genAuxBind (GenTag2Con tycon)
= mk_FunBind (getSrcSpan tycon) rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
(nlHsTyVar (getRdrName tycon))))]
where
rdr_name = tag2con_RDR tycon
gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
genAuxBind (GenMaxTag tycon)
= mkVarBind (getSrcSpan tycon) rdr_name
(nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
where
rdr_name = maxtag_RDR tycon
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
\end{code}
%************************************************************************
......
......@@ -403,39 +403,37 @@ tcInstDecls2 tycl_decls inst_decls
The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
the dictionary function for this instance declaration. For example
\begin{verbatim}
instance Foo a => Foo [a] where
op1 x = ...
op2 y = ...
\end{verbatim}
might generate something like
\begin{verbatim}
dfun.Foo.List dFoo_a = let op1 x = ...
op2 y = ...
in
Dict [op1, op2]
\end{verbatim}
HOWEVER, if the instance decl has no context, then it returns a
bigger @HsBinds@ with declarations for each method. For example
\begin{verbatim}
instance Foo [a] where
op1 x = ...
op2 y = ...
\end{verbatim}
might produce
\begin{verbatim}
dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
const.Foo.op1.List a x = ...
const.Foo.op2.List a y = ...
\end{verbatim}
This group may be mutually recursive, because (for example) there may
be no method supplied for op2 in which case we'll get
\begin{verbatim}
const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
\end{verbatim}
that is, the default method applied to the dictionary at this type.
that is, the default method applied to the dictionary at this type.
What we actually produce in either case is:
AbsBinds [a] [dfun_theta_dicts]
......@@ -447,7 +445,6 @@ What we actually produce in either case is:
The "maybe" says that we only ask AbsBinds to make global constant methods
if the dfun_theta is empty.
For an instance declaration, say,
......@@ -463,8 +460,6 @@ Notice that we pass it the superclass dictionaries at the instance type; this
is the ``Mark Jones optimisation''. The stuff before the "=>" here
is the @dfun_theta@ below.
First comes the easy case of a non-local instance decl.
\begin{code}
tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
......@@ -473,23 +468,23 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
------------------------
-- Derived newtype instances; surprisingly tricky!
--
-- In the case of a newtype, things are rather easy
-- class Show a => Foo a b where ...
-- newtype T a = MkT (Tree [a]) deriving( Foo Int )
-- newtype N a = MkN (Tree [a]) deriving( Foo Int )
--
-- The newtype gives an FC axiom looking like
-- axiom CoT a :: T a :=: Tree [a]
-- axiom CoN a :: N a :=: Tree [a]
-- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
--
-- So all need is to generate a binding looking like:
-- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
-- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
-- case df `cast` (Foo Int (sym (CoT a))) of
-- dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
-- dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
-- case df `cast` (Foo Int (sym (CoN a))) of
-- Foo _ op1 .. opn -> Foo ds op1 .. opn
--
-- If there are no superclasses, matters are simpler, because we don't need the case
-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
= do { let dfun_id = instanceDFunId ispec
rigid_info = InstSkol
origin = SigOrigin rigid_info
......@@ -497,46 +492,43 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
-- inst_head_ty is a PredType
; inst_loc <- getInstLoc origin
; (rep_dict_id : sc_dict_ids, wrap_fn, sc_binds)
<- make_wrapper inst_loc tvs theta mb_preds
-- Here, we are relying on the order of dictionary
-- arguments built by NewTypeDerived in TcDeriv;
-- namely, that the rep_dict_id comes first
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
cls_tycon = classTyCon cls
the_coercion = make_coercion cls_tycon cls_inst_tys
coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id)
; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
(class_tyvars, sc_theta, _, op_items) = classBigSig cls
cls_tycon = classTyCon cls
sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
(nt_tycon, tc_args) = tcSplitTyConApp last_ty -- Can't fail
rep_ty = newTyConInstRhs nt_tycon tc_args
rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
-- In our example, rep_pred is (Foo Int (Tree [a]))
the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
-- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) }
; inst_loc <- getInstLoc origin
; sc_loc <- getInstLoc InstScOrigin
; dfun_dicts <- newDictBndrs inst_loc theta
; sc_dicts <- newDictBndrs sc_loc sc_theta'
; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
; rep_dict <- newDictBndr inst_loc rep_pred
-- Figure out bindings for the superclass context from dfun_dicts
-- Don't include this_dict in the 'givens', else
-- wanted_sc_insts get bound by just selecting from this_dict!!
; sc_binds <- addErrCtxt superClassCtxt $
tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict))
; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
; return (unitBag $ noLoc $
AbsBinds tvs (map instToId dfun_dicts)
[(tvs, dfun_id, instToId this_dict, [])]
(dict_bind `consBag` sc_binds)) }
where
-----------------------
-- 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))
......@@ -546,25 +538,24 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
-- 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
make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
| Just co_con <- newTyConCo_maybe nt_tycon
, let co = mkSymCoercion (mkTyConApp co_con tc_args)
= WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
= WpCo (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [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 C tys scs coreced_rep_dict)
-- returns