X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=ad640efec88affa1789b7595c39f1a52a916668d;hp=4d19bcb39dfe3de50b7e1685008f813e34c68a29;hb=HEAD;hpb=9532c3854099efe7a8cb3a07e75c8c3204b56e86 diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 4d19bcb..ad640ef 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -41,7 +41,8 @@ import Name import HscTypes import PrelInfo -import PrelNames +import MkCore ( eRROR_ID ) +import PrelNames hiding (error_RDR) import PrimOp import SrcLoc import TyCon @@ -49,7 +50,6 @@ import TcType import TysPrim import TysWiredIn import Type -import Var( TyVar ) import TypeRep import VarSet import State @@ -167,7 +167,7 @@ gen_Eq_binds loc tycon where (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) + | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) no_nullary_cons = null nullary_cons @@ -184,10 +184,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 +321,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 = [] @@ -775,7 +778,7 @@ gen_Ix_binds loc tycon single_con_range = mk_easy_FunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - nlHsDo ListComp stmts con_expr + noLoc (mkHsComp ListComp stmts con_expr) where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -889,15 +892,15 @@ gen_Read_binds get_fixity loc tycon read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])] + [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the -- enclosing "parens" call, so here we must match the naked -- data_con_str con - match_con con | isSym con_str = symbol_pat con_str - | otherwise = ident_pat con_str + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str where con_str = data_con_str con -- For nullary constructors we must match Ident s for normal constrs @@ -921,12 +924,12 @@ gen_Read_binds get_fixity loc tycon prefix_parser = mk_parser prefix_prec prefix_stmts body read_prefix_con - | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] - | otherwise = [bindLex (ident_pat con_str)] + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str read_infix_con - | isSym con_str = [bindLex (symbol_pat con_str)] - | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] prefix_stmts -- T a b c = read_prefix_con ++ read_args @@ -961,15 +964,23 @@ gen_Read_binds get_fixity loc tycon ------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) - bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] + bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' - ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" - symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP + symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP data_con_str con = occNameString (getOccName con) @@ -987,11 +998,9 @@ gen_Read_binds get_fixity loc tycon -- or (#) = 4 -- Note the parens! read_lbl lbl | isSym lbl_str - = [read_punc "(", - bindLex (symbol_pat lbl_str), - read_punc ")"] + = [read_punc "(", symbol_pat lbl_str, read_punc ")"] | otherwise - = [bindLex (ident_pat lbl_str)] + = ident_h_pat lbl_str where lbl_str = occNameString (getOccName lbl) \end{code} @@ -1036,17 +1045,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 +1240,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 @@ -1288,18 +1300,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 +1394,16 @@ 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 $ 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 + 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 @@ -1443,11 +1462,13 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar where (_, xc) = go co x (yr,yc) = go co y go co ty@(TyConApp con args) - | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True) - | null args = (caseTrivial,False) -- T - | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty - | last xcs = -- T (..no var..) ty - (caseTyApp (fst (splitAppTy ty)) (last xrs),True) + | not (or xcs) = (caseTrivial, False) -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True) + | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty + | otherwise = -- T (..no var..) ty + (caseTyApp (fst (splitAppTy ty)) (last xrs), True) where (xrs,xcs) = unzip (map (go co) args) go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True) where (xr,xc) = go co x @@ -1545,7 +1566,8 @@ 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 $ 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 @@ -1596,7 +1618,8 @@ 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 $ 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 @@ -1644,70 +1667,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 $ + mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta 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 + = (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 $ mkForAllTys (tyConTyVars tycon) $ + 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 +1750,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} %************************************************************************ @@ -1736,7 +1767,27 @@ mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc %************************************************************************ -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 @@ -1785,7 +1836,7 @@ assoc_ty_id cls_str _ tbl ty text "for primitive type" <+> ppr ty) | otherwise = head res where - res = [id | (ty',id) <- tbl, ty `tcEqType` ty'] + res = [id | (ty',id) <- tbl, ty `eqType` ty'] ----------------------------------------------------------------------- @@ -1834,8 +1885,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}