X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=525f0950b0b08d3e2aed107fde38b1d4c25bf843;hp=4d19bcb39dfe3de50b7e1685008f813e34c68a29;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=9532c3854099efe7a8cb3a07e75c8c3204b56e86 diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 4d19bcb..525f095 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1288,18 +1288,21 @@ 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") + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, + constr_RDR, dataType_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") +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} @@ -1379,12 +1382,18 @@ gen_Functor_binds loc tycon = (unitBag fmap_bind, []) where data_cons = tyConDataCons tycon - - fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons) + fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns + fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs where parts = foldDataConArgs ft_fmap con + -- Catch-all eqn looks like fmap _ _ = error "impossible" + -- It's needed if there no data cons at all + eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] + (error_Expr "Void fmap")] + | otherwise = map fmap_eqn data_cons + ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) -- Tricky higher order type; I can't say I fully understand this code :-( ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x @@ -1545,7 +1554,10 @@ gen_Foldable_binds loc tycon where data_cons = tyConDataCons tycon - foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons) + foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns + eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat] + (error_Expr "Void foldr")] + | otherwise = map foldr_eqn data_cons foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs where parts = foldDataConArgs ft_foldr con @@ -1596,7 +1608,10 @@ gen_Traversable_binds loc tycon where data_cons = tyConDataCons tycon - traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons) + traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns + eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] + (error_Expr "Void traverse")] + | otherwise = map traverse_eqn data_cons traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs where parts = foldDataConArgs ft_trav con @@ -1644,70 +1659,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) (L loc 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 = HsCoreTy $ + mkForAllTys (tyConTyVars tycon) $ + mkParentType tycon `mkFunTy` intPrimTy - -- 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) (L loc sig_ty))) where + sig_ty = HsCoreTy $ intTy `mkFunTy` mkParentType 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) (L loc sig_ty))) where rdr_name = maxtag_RDR tycon + sig_ty = HsCoreTy intTy + 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 @@ -1727,6 +1742,14 @@ mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc mk_constr_name :: DataCon -> RdrName -- "$cC" mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc + +mkParentType :: TyCon -> Type +-- Turn the representation tycon of a family into +-- a use of its family constructor +mkParentType tc + = case tyConFamInst_maybe tc of + Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) + Just (fam_tc,tys) -> mkTyConApp fam_tc tys \end{code} %************************************************************************ @@ -1834,8 +1857,8 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! --- impossible_Expr :: LHsExpr RdrName --- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv")) +error_Expr :: String -> LHsExpr RdrName +error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred}