X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=8bbc27a64a78aeebe24493442a1a994368074413;hb=d91c667d5cfb835b0d60ffb6264934c1b49a44aa;hp=c579b94bf9f34033f28db9f3e137ca8d16d4f443;hpb=8fda9784f1eff82aa243073fd31b181080be3109;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index c579b94..8bbc27a 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -42,7 +42,6 @@ import Name import HscTypes import PrelInfo import PrelNames -import MkId import PrimOp import SrcLoc import TyCon @@ -58,9 +57,7 @@ import Util import MonadUtils import Outputable import FastString -import OccName import Bag - import Data.List ( partition, intersperse ) \end{code} @@ -569,8 +566,8 @@ gen_Bounded_binds loc tycon data_cons = tyConDataCons tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -580,9 +577,9 @@ gen_Bounded_binds loc tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind loc minBound_RDR $ + min_bound_1con = mkHsVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind loc maxBound_RDR $ + max_bound_1con = mkHsVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -721,7 +718,7 @@ gen_Ix_binds loc tycon mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) (nlHsApp (nlHsVar range_RDR) - (nlTuple [nlHsVar a, nlHsVar b] Boxed)) + (mkLHsVarTuple [a,b])) ---------------- single_con_index @@ -743,11 +740,11 @@ gen_Ix_binds loc tycon ) plus_RDR ( genOpApp ( (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (nlTuple [nlHsVar l, nlHsVar u] Boxed)) + (mkLHsVarTuple [l,u])) ) times_RDR (mk_index rest) ) mk_one l u i - = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i] + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] ------------------ single_con_inRange @@ -756,8 +753,7 @@ gen_Ix_binds loc tycon con_pat cs_needed] $ foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where - in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, - nlHsVar c] + in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] \end{code} %************************************************************************ @@ -812,16 +808,16 @@ gen_Read_binds get_fixity loc tycon where ----------------------------------------------------------------------- default_readlist - = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) default_readlistprec - = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - read_prec = mkVarBind loc readPrec_RDR + read_prec = mkHsVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) @@ -835,9 +831,8 @@ gen_Read_binds get_fixity loc tycon _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - Boxed + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] read_non_nullary_con data_con | is_infix = mk_parser infix_prec infix_stmts body @@ -966,7 +961,7 @@ gen_Show_binds get_fixity loc tycon = (listToBag [shows_prec, show_list], []) where ----------------------------------------------------------------------- - show_list = mkVarBind loc showList_RDR + 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)) @@ -1098,7 +1093,7 @@ gen_Typeable_binds loc tycon [nlWildPat] (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where - tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) + tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function @@ -1241,7 +1236,10 @@ infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") %************************************************************************ %* * - Functor instances + Functor instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + %* * %************************************************************************ @@ -1444,7 +1442,10 @@ mkSimpleTupleCase match_for_con boxity insides x = do %************************************************************************ %* * - Foldable instances + Foldable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + %* * %************************************************************************ @@ -1472,7 +1473,7 @@ gen_Foldable_binds loc tycon where data_cons = tyConDataCons tycon - foldr_bind = L loc $ mkFunBind (L loc foldr_RDR) (map foldr_eqn data_cons) + foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (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 @@ -1494,7 +1495,9 @@ gen_Foldable_binds loc tycon %************************************************************************ %* * - Traversable instances + Traversable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html %* * %************************************************************************ @@ -1613,7 +1616,7 @@ genAuxBind loc (GenTag2Con tycon) rdr_name = tag2con_RDR tycon genAuxBind loc (GenMaxTag tycon) - = mkVarBind loc rdr_name + = mkHsVarBind loc rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where rdr_name = maxtag_RDR tycon @@ -1621,16 +1624,16 @@ genAuxBind loc (GenMaxTag tycon) data_cons -> toInteger ((length data_cons) - fIRST_TAG) genAuxBind loc (MkTyCon tycon) -- $dT - = mkVarBind loc (mk_data_type_name tycon) - ( nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) + = mkHsVarBind loc (mk_data_type_name tycon) + ( nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) `nlHsApp` nlList constrs ) where constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] genAuxBind loc (MkDataCon dc) -- $cT1 etc - = mkVarBind loc (mk_constr_name dc) - (nlHsApps mkConstr_RDR constr_args) + = mkHsVarBind loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR constr_args) where constr_args = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag