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}
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
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}
%************************************************************************
projects / ghc-hetmet.git / blobdiff