X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=8f8168bc9418d4c59962866e2cb0d86fbe874ab6;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=e922146fc60dae0a5071003e9f469ab7e2a489bd;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index e922146..8f8168b 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -32,31 +32,26 @@ import HsSyn import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual, mkDerivedRdrName ) import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) ) -import FieldLabel ( fieldLabelName ) -import DataCon ( isNullaryDataCon, dataConTag, +import DataCon ( isNullarySrcDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, dataConName, + DataCon, dataConName, dataConIsInfix, dataConFieldLabels ) -import Name ( getOccString, getOccName, getSrcLoc, occNameString, - occNameUserString, - Name, NamedThing(..), - isDataSymOcc, isSymOcc - ) +import Name ( getOccString, getSrcLoc, Name, NamedThing(..) ) import HscTypes ( FixityEnv, lookupFixity ) import PrelInfo import PrelNames -import TysWiredIn import MkId ( eRROR_ID ) import PrimOp ( PrimOp(..) ) import SrcLoc ( Located(..), noLoc, srcLocSpan ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, +import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity, maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName ) import TcType ( isUnLiftedType, tcEqType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTyCon ) -import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon ) +import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, + intDataCon_RDR, true_RDR, false_RDR ) import Util ( zipWithEqual, isSingleton, zipWith3Equal, nOfThem, zipEqual ) import Char ( isAlpha ) @@ -157,14 +152,14 @@ gen_Eq_binds tycon (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullaryDataCon (tyConDataCons tycon) + | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) rest = if (null nullary_cons) then case maybeTyConSingleCon tycon of Just _ -> [] Nothing -> -- if cons don't match, then False - [([wildPat, wildPat], false_Expr)] + [([nlWildPat, nlWildPat], false_Expr)] else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] @@ -172,7 +167,7 @@ gen_Eq_binds tycon in listToBag [ mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag ( + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyLHsBinds ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) ] where @@ -319,7 +314,7 @@ gen_Ord_binds tycon single_con_type = isSingleton tycon_data_cons (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullaryDataCon tycon_data_cons + | otherwise = partition isNullarySrcDataCon tycon_data_cons cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match cmp_eq_match @@ -329,13 +324,13 @@ gen_Ord_binds tycon -- Catch this specially to avoid warnings -- about overlapping patterns from the desugarer, -- and to avoid unnecessary pattern-matching - = [([wildPat,wildPat], eqTag_Expr)] + = [([nlWildPat,nlWildPat], eqTag_Expr)] | otherwise = map pats_etc nonnullary_cons ++ (if single_con_type then -- Omit wildcards when there's just one [] -- constructor, to silence desugarer else - [([wildPat, wildPat], default_rhs)]) + [([nlWildPat, nlWildPat], default_rhs)]) where pats_etc data_con @@ -422,7 +417,7 @@ gen_Enum_binds tycon occ_nm = getOccString tycon succ_enum - = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -432,7 +427,7 @@ gen_Enum_binds tycon nlHsIntLit 1])) pred_enum - = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -442,7 +437,7 @@ gen_Enum_binds tycon nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) @@ -450,7 +445,7 @@ gen_Enum_binds tycon (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) enum_from - = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR tycon), @@ -459,7 +454,7 @@ gen_Enum_binds tycon (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -472,7 +467,7 @@ gen_Enum_binds tycon )) from_enum - = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} @@ -586,7 +581,7 @@ gen_Ix_binds tycon enum_range = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $ + [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ @@ -597,8 +592,8 @@ gen_Ix_binds tycon enum_index = mk_easy_FunBind tycon_loc index_RDR [noLoc (AsPat (noLoc c_RDR) - (nlTuplePat [a_Pat, wildPat] Boxed)), - d_Pat] emptyBag ( + (nlTuplePat [a_Pat, nlWildPat] Boxed)), + d_Pat] emptyLHsBinds ( nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( @@ -615,7 +610,7 @@ gen_Ix_binds tycon enum_inRange = mk_easy_FunBind tycon_loc inRange_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag ( + [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -649,7 +644,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $ + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $ nlHsDo ListComp stmts where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -680,7 +675,7 @@ gen_Ix_binds tycon range_size = mk_easy_FunBind tycon_loc rangeSize_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag ( + [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds ( genOpApp ( (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed, b_Expr]) @@ -691,7 +686,7 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] - emptyBag ( + emptyLHsBinds ( 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, @@ -756,7 +751,7 @@ gen_Read_binds get_fixity tycon loc = getSrcSpan tycon data_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons read_prec = mkVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) @@ -784,7 +779,7 @@ gen_Read_binds get_fixity tycon | otherwise = prefix_stmts prefix_stmts -- T a b c - = [bindLex (ident_pat (data_con_str data_con))] + = [bindLex (ident_pat (data_con_str_w_parens data_con))] ++ read_args ++ [result_stmt data_con as_needed] @@ -795,7 +790,7 @@ gen_Read_binds get_fixity tycon result_stmt data_con [a1,a2]] lbl_stmts -- T { f1 = a, f2 = b } - = [bindLex (ident_pat (data_con_str data_con)), + = [bindLex (ident_pat (data_con_str_w_parens data_con)), read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) ++ [read_punc "}", result_stmt data_con as_needed] @@ -805,7 +800,7 @@ gen_Read_binds get_fixity tycon con_arity = dataConSourceArity data_con labels = dataConFieldLabels data_con dc_nm = getName data_con - is_infix = isDataSymOcc (getOccName dc_nm) + is_infix = dataConIsInfix data_con as_needed = take con_arity as_RDRs read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) (read_a1:read_a2:_) = read_args @@ -824,7 +819,8 @@ gen_Read_binds get_fixity tycon ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo" symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>" - data_con_str con = mkHsString (occNameUserString (getOccName con)) + data_con_str con = mkHsString (occNameUserString (getOccName con)) + data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con)) read_punc c = bindLex (punc_pat c) read_arg a ty @@ -847,7 +843,7 @@ gen_Read_binds get_fixity tycon bindLex (symbol_pat lbl_lit), read_punc ")"] where - lbl_str = occNameUserString (getOccName (fieldLabelName lbl)) + lbl_str = occNameUserString (getOccName lbl) lbl_lit = mkHsString lbl_str is_id_start c = isAlpha c || c == '_' \end{code} @@ -898,7 +894,7 @@ gen_Show_binds get_fixity tycon pats_etc data_con | nullary_con = -- skip the showParen junk... ASSERT(null bs_needed) - ([wildPat, con_pat], mk_showString_app con_str) + ([nlWildPat, con_pat], mk_showString_app con_str) | otherwise = ([a_Pat, con_pat], showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one)))) @@ -917,24 +913,22 @@ gen_Show_binds get_fixity tycon dc_nm = getName data_con dc_occ_nm = getOccName data_con con_str = occNameUserString dc_occ_nm + op_con_str = occNameUserString_with_parens dc_occ_nm show_thingies | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2] - | record_syntax = mk_showString_app (con_str ++ " {") : + | record_syntax = mk_showString_app (op_con_str ++ " {") : show_record_args ++ [mk_showString_app "}"] - | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args + | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args - show_label l = mk_showString_app (the_name ++ " = ") + show_label l = mk_showString_app (nm ++ " = ") -- Note the spaces around the "=" sign. If we don't have them -- then we get Foo { x=-1 } and the "=-" parses as a single -- lexeme. Only the space after the '=' is necessary, but -- it seems tidier to have them both sides. where - occ_nm = getOccName (fieldLabelName l) - nm = occNameUserString occ_nm - is_op = isSymOcc occ_nm -- Legal, but rare. - the_name | is_op = '(':nm ++ ")" - | otherwise = nm + occ_nm = getOccName l + nm = occNameUserString_with_parens occ_nm show_args = zipWith show_arg bs_needed arg_tys (show_arg1:show_arg2:_) = show_args @@ -955,11 +949,18 @@ gen_Show_binds get_fixity tycon box_if_necy "Show" tycon (nlHsVar b) arg_ty] -- Fixity stuff - is_infix = isDataSymOcc dc_occ_nm + is_infix = dataConIsInfix data_con con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm arg_prec | record_syntax = 0 -- Record fields don't need parens | otherwise = con_prec_plus_one +occNameUserString_with_parens :: OccName -> String +occNameUserString_with_parens occ + | isSymOcc occ = '(':nm ++ ")" + | otherwise = nm + where + nm = occNameUserString occ + mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} @@ -993,27 +994,30 @@ From the data type we generate - instance (Typeable a, Typeable b) => Typeable (T a b) where - typeOf _ = mkTypeRep (mkTyConRep "T") - [typeOf (undefined::a), - typeOf (undefined::b)] + instance Typeable2 T where + typeOf2 _ = mkTyConApp (mkTyConRep "T") [] -Notice the use of lexically scoped type variables. +We are passed the Typeable2 class as well as T \begin{code} gen_Typeable_binds :: TyCon -> LHsBinds RdrName gen_Typeable_binds tycon = unitBag $ - mk_easy_FunBind tycon_loc typeOf_RDR [wildPat] emptyBag - (nlHsApps mkTypeRep_RDR [tycon_rep, arg_reps]) + mk_easy_FunBind tycon_loc + (mk_typeOf_RDR tycon) -- Name of appropriate type0f function + [nlWildPat] emptyLHsBinds + (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where tycon_loc = getSrcSpan tycon - tyvars = tyConTyVars tycon tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) - arg_reps = nlList (map mk tyvars) - mk tyvar = nlHsApp (nlHsVar typeOf_RDR) - (noLoc (ExprWithTySig (nlHsVar undefined_RDR) - (nlHsTyVar (getRdrName tyvar)))) + +mk_typeOf_RDR :: TyCon -> RdrName +-- Use the arity of the TyCon to make the right typeOfn function +mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) + where + arity = tyConArity tycon + suffix | arity == 0 = "" + | otherwise = show arity \end{code} @@ -1030,19 +1034,20 @@ From the data type we generate - $cT1 = mkConstr 1 "T1" Prefix - $cT2 = mkConstr 2 "T2" Prefix - $dT = mkDataType [$con_T1, $con_T2] + $cT1 = mkDataCon $dT "T1" Prefix + $cT2 = mkDataCon $dT "T2" Prefix + $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] + -- the [] is for field labels. instance (Data a, Data b) => Data (T a b) where gfoldl k z (T1 a b) = z T `k` a `k` b gfoldl k z T2 = z T2 -- ToDo: add gmapT,Q,M, gfoldr - - fromConstr c = case conIndex c of - I# 1# -> T1 undefined undefined - I# 2# -> T2 - + + gunfold k z c = case conIndex c of + I# 1# -> k (k (z T1)) + I# 2# -> z T2 + toConstr (T1 _ _) = $cT1 toConstr T2 = $cT2 @@ -1054,13 +1059,15 @@ gen_Data_binds :: FixityEnv -> (LHsBinds RdrName, -- The method bindings LHsBinds RdrName) -- Auxiliary bindings gen_Data_binds fix_env tycon - = (listToBag [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind], + = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors datatype_bind `consBag` listToBag (map mk_con_bind data_cons)) where - tycon_loc = getSrcSpan tycon + tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon - data_cons = tyConDataCons tycon + data_cons = tyConDataCons tycon + n_cons = length data_cons + one_constr = n_cons == 1 ------------ gfoldl gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) @@ -1072,52 +1079,83 @@ gen_Data_binds fix_env tycon as_needed = take (dataConSourceArity con) as_RDRs mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) - ------------ fromConstr - fromCon_bind = mk_FunBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)] - from_con_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) - (map from_con_alt data_cons) - from_con_alt dc = mkSimpleHsAlt (nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))]) - (nlHsVarApps (getRdrName dc) - (replicate (dataConSourceArity dc) undefined_RDR)) + ------------ gunfold + gunfold_bind = mk_FunBind tycon_loc + gunfold_RDR + [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], + gunfold_rhs)] + + gunfold_rhs + | one_constr = mk_unfold_rhs (head data_cons) -- No need for case + | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map gunfold_alt data_cons) + + gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + mk_unfold_rhs dc = foldr nlHsApp + (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) + (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid + -- redundant test, and annoying warning + | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor + | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))] + where + tag = dataConTag dc ------------ toConstr toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc)) ------------ dataTypeOf - dataTypeOf_bind = mk_easy_FunBind tycon_loc dataTypeOf_RDR [wildPat] - emptyBag (nlHsVar data_type_name) + dataTypeOf_bind = mk_easy_FunBind + tycon_loc + dataTypeOf_RDR + [nlWildPat] + emptyLHsBinds + (nlHsVar data_type_name) ------------ $dT + data_type_name = mkDerivedRdrName tycon_name mkDataTOcc - datatype_bind = mkVarBind tycon_loc data_type_name - (nlHsVar mkDataType_RDR `nlHsApp` - nlList constrs) + datatype_bind = mkVarBind + tycon_loc + data_type_name + ( nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) + `nlHsApp` nlList constrs + ) constrs = [nlHsVar (mk_constr_name con) | con <- data_cons] ------------ $cT1 etc mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc - mk_con_bind dc = mkVarBind tycon_loc (mk_constr_name dc) - (nlHsApps mkConstr_RDR (constr_args dc)) - constr_args dc = [nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name - nlHsVar fixity] -- Fixity + mk_con_bind dc = mkVarBind + tycon_loc + (mk_constr_name dc) + (nlHsApps mkConstr_RDR (constr_args dc)) + constr_args dc = + [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar data_type_name, -- DataType + nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name + nlList labels, -- Field labels + nlHsVar fixity] -- Fixity where + labels = map (nlHsLit . mkHsString . getOccString) + (dataConFieldLabels dc) dc_occ = getOccName dc is_infix = isDataSymOcc dc_occ fixity | is_infix = infix_RDR | otherwise = prefix_RDR -gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl") -fromConstr_RDR = varQual_RDR gENERICS_Name FSLIT("fromConstr") -toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf") -mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr") -mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType") -conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("conIndex") -prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix") -infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix") +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") +mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr") +mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType") +conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex") +prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix") +infix_RDR = dataQual_RDR gENERICS FSLIT("Infix") \end{code} %************************************************************************ @@ -1303,9 +1341,8 @@ eq_Expr tycon ty a b = genOpApp a eq_op b where eq_op | not (isUnLiftedType ty) = eq_RDR - | otherwise = + | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty) -- we have to do something special for primitive things... - primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty) \end{code} \begin{code} @@ -1417,6 +1454,8 @@ a_Pat = nlVarPat a_RDR b_Pat = nlVarPat b_RDR c_Pat = nlVarPat c_RDR d_Pat = nlVarPat d_RDR +k_Pat = nlVarPat k_RDR +z_Pat = nlVarPat z_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions