Commit a8407757 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Add type signatures in "deriving" bindings

parent c61a92e8
......@@ -334,9 +334,10 @@ renameDeriv is_boot gen_binds insts
-- notably "con2tag" and/or "tag2con" functions.
-- Bring those names into scope before renaming the instances themselves
; loc <- getSrcSpanM -- Generic loc for shared bindings
; let aux_binds = listToBag $ map (genAuxBind loc) $
rm_dups [] $ concat deriv_aux_binds
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds [])
; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $
rm_dups [] $ concat deriv_aux_binds
aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
; let aux_names = collectHsValBinders rn_aux_lhs
; bindLocalNames aux_names $
......
......@@ -1289,17 +1289,19 @@ kind2 = liftedTypeKind `mkArrowKind` kind1
gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
\end{code}
......@@ -1656,70 +1658,70 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
\begin{code}
genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
| lots_of_constructors
= mk_FunBind loc rdr_name [([], get_tag_rhs)]
| otherwise
= mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
= (mk_FunBind loc rdr_name eqns,
L loc (TypeSig (L loc rdr_name) sig_ty))
where
rdr_name = con2tag_RDR tycon
tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
-- We can't use gerRdrName because that makes an Exact RdrName
-- and we can't put them in the LocalRdrEnv
sig_ty = genForAllTy loc tycon $ \hs_tc_app ->
hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon)
-- Give a signature to the bound variable, so
-- that the case expression generated by getTag is
-- monomorphic. In the push-enter model we get better code.
get_tag_rhs = L loc $ ExprWithTySig
(nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
(nlHsApp (nlHsVar getTag_RDR) a_Expr)))
(noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
(noLoc []) con2tag_ty))
lots_of_constructors = tyConFamilySize tycon > 8
-- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
-- but we don't do vectored returns any more.
con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
`nlHsFunTy`
nlHsTyVar (getRdrName intPrimTyCon)
eqns | lots_of_constructors = [get_tag_eqn]
| otherwise = map mk_eqn (tyConDataCons tycon)
lots_of_constructors = tyConFamilySize tycon > 8
-- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
-- but we don't do vectored returns any more.
get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
mk_stuff con = ([nlWildConPat con],
nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
mk_eqn con = ([nlWildConPat con],
nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
genAuxBind loc (GenTag2Con tycon)
= mk_FunBind loc rdr_name
= ASSERT( null (tyConTyVars tycon) )
(mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
(nlHsTyVar (getRdrName tycon))))]
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
L loc (TypeSig (L loc rdr_name) sig_ty))
where
sig_ty = nlHsTyVar (getRdrName intPrimTyCon)
`nlHsFunTy` (nlHsTyVar (getRdrName tycon))
rdr_name = tag2con_RDR tycon
genAuxBind loc (GenMaxTag tycon)
= mkHsVarBind loc rdr_name
(nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig (L loc rdr_name) sig_ty))
where
rdr_name = maxtag_RDR tycon
sig_ty = nlHsTyVar (getRdrName intPrimTyCon)
rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
genAuxBind loc (MkTyCon tycon) -- $dT
= mkHsVarBind loc (mk_data_type_name tycon)
( nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
`nlHsApp` nlList constrs )
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig (L loc rdr_name) sig_ty))
where
constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
rdr_name = mk_data_type_name tycon
sig_ty = nlHsTyVar dataType_RDR
constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
`nlHsApp` nlList constrs
genAuxBind loc (MkDataCon dc) -- $cT1 etc
= mkHsVarBind loc (mk_constr_name dc)
(nlHsApps mkConstr_RDR constr_args)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig (L loc rdr_name) sig_ty))
where
rdr_name = mk_constr_name dc
sig_ty = nlHsTyVar constr_RDR
rhs = nlHsApps mkConstr_RDR constr_args
constr_args
= [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
......@@ -1739,6 +1741,18 @@ mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
mk_constr_name :: DataCon -> RdrName -- "$cC"
mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
genForAllTy :: SrcSpan -> TyCon
-> (LHsType RdrName -> LHsType RdrName)
-> LHsType RdrName
-- Wrap a forall type for the variables of the TyCOn
genForAllTy loc tc thing_inside
= L loc $ mkExplicitHsForAllTy (userHsTyVarBndrs (map (L loc) tvs)) (L loc []) $
thing_inside (nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs))
where
tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tc)
-- We can't use getRdrName because that makes an Exact RdrName
-- and we can't put them in the LocalRdrEnv
\end{code}
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment