X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=4e95ad31b2a0027027be76b86f8caf0da2296b1d;hp=2c0b89df089dbcecf43e6aadb53df76b894300fb;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=eabf04b78e41b2b4b614b3e8ee83a3eb0d2722d6 diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c0b89d..4e95ad3 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -41,6 +41,7 @@ import Name import HscTypes import PrelInfo +import MkCore ( eRROR_ID ) import PrelNames import PrimOp import SrcLoc @@ -184,10 +185,10 @@ gen_Eq_binds loc tycon aux_binds | no_nullary_cons = [] | otherwise = [GenCon2Tag tycon] - method_binds = listToBag [ - mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( - nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))] + method_binds = listToBag [eq_bind, ne_bind] + eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest) + ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( + nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) ------------------------------------------------------------------ pats_etc data_con @@ -321,6 +322,9 @@ gtResult OrdGT = true_Expr ------------ gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ord_binds loc tycon + | null tycon_data_cons -- No data-cons => invoke bale-out case + = (unitBag $ mk_FunBind loc compare_RDR [], []) + | otherwise = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds) where aux_binds | single_con_type = [] @@ -1036,17 +1040,18 @@ gen_Show_binds get_fixity loc tycon show_list = mkHsVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- - shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) - where - pats_etc data_con - | nullary_con = -- skip the showParen junk... - ASSERT(null bs_needed) - ([nlWildPat, con_pat], mk_showString_app op_con_str) - | otherwise = - ([a_Pat, con_pat], - showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one)))) - (nlHsPar (nested_compose_Expr show_thingies))) - where + data_cons = tyConDataCons tycon + shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons) + + pats_etc data_con + | nullary_con = -- skip the showParen junk... + ASSERT(null bs_needed) + ([nlWildPat, con_pat], mk_showString_app op_con_str) + | otherwise = + ([a_Pat, con_pat], + showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one)))) + (nlHsPar (nested_compose_Expr show_thingies))) + where data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con bs_needed = take con_arity bs_RDRs @@ -1230,7 +1235,9 @@ gen_Data_binds loc tycon ------------ gfoldl gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons) - gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], + + gfoldl_eqn con + = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) where con_name :: RdrName @@ -1382,14 +1389,12 @@ gen_Functor_binds loc tycon = (unitBag fmap_bind, []) where data_cons = tyConDataCons tycon - fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns + fmap_bind = L loc $ mkRdrFunBind (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 @@ -1554,10 +1559,8 @@ gen_Foldable_binds loc tycon where data_cons = tyConDataCons tycon - 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_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns + eqns = 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 @@ -1608,10 +1611,8 @@ gen_Traversable_binds loc tycon where data_cons = tyConDataCons tycon - 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_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns + eqns = map traverse_eqn data_cons traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs where parts = foldDataConArgs ft_trav con @@ -1662,12 +1663,13 @@ fiddling around. genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName) genAuxBind loc (GenCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) where rdr_name = con2tag_RDR tycon - sig_ty = genForAllTy loc tycon $ \hs_tc_app -> - hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon) + sig_ty = HsCoreTy $ + mkForAllTys (tyConTyVars tycon) $ + mkParentType tycon `mkFunTy` intPrimTy lots_of_constructors = tyConFamilySize tycon > 8 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS @@ -1683,23 +1685,22 @@ genAuxBind loc (GenCon2Tag tycon) nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) genAuxBind loc (GenTag2Con tycon) - = ASSERT( null (tyConTyVars tycon) ) - (mk_FunBind loc rdr_name + = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) where - sig_ty = nlHsTyVar (getRdrName intTyCon) - `nlHsFunTy` (nlHsTyVar (getRdrName tycon)) + sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ + intTy `mkFunTy` mkParentType tycon rdr_name = tag2con_RDR tycon genAuxBind loc (GenMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) where rdr_name = maxtag_RDR tycon - sig_ty = nlHsTyVar (getRdrName intTyCon) + 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) @@ -1743,17 +1744,13 @@ 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 +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} %************************************************************************ @@ -1763,7 +1760,27 @@ genForAllTy loc tc thing_inside %************************************************************************ -ToDo: Better SrcLocs. +\begin{code} +mk_FunBind :: SrcSpan -> RdrName + -> [([LPat RdrName], LHsExpr RdrName)] + -> LHsBind RdrName +mk_FunBind loc fun pats_and_exprs + = L loc $ mkRdrFunBind (L loc fun) matches + where + matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] + +mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName +mkRdrFunBind fun@(L _ fun_rdr) matches + | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds] + -- Catch-all eqn looks like + -- fmap = error "Void fmap" + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See Trac #4302 + | otherwise = mkFunBind fun matches + where + str = "Void " ++ occNameString (rdrNameOcc fun_rdr) +\end{code} \begin{code} box_if_necy :: String -- The class involved