X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=94bb15285001c091c3b129d2a35cfd1a899a34a4;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=b18451321cf07cfbde8c4b15d342801874b96971;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b184513..94bb152 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -54,7 +54,6 @@ import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, intDataCon_RDR, true_RDR, false_RDR ) import Util ( zipWithEqual, isSingleton, zipWith3Equal, nOfThem, zipEqual ) -import Char ( isAlpha ) import Constants import List ( partition, intersperse ) import Outputable @@ -167,7 +166,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] emptyLHsBinds ( + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) ] where @@ -298,8 +297,10 @@ gen_Ord_binds tycon tycon_loc = getSrcSpan tycon -------------------------------------------------------------------- - compare = mk_easy_FunBind tycon_loc compare_RDR - [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs + compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames) + compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] + cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) []) + compare_rhs | single_con_type = cmp_eq_Expr a_Expr b_Expr | otherwise @@ -417,7 +418,7 @@ gen_Enum_binds tycon occ_nm = getOccString tycon succ_enum - = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -427,7 +428,7 @@ gen_Enum_binds tycon nlHsIntLit 1])) pred_enum - = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -437,7 +438,7 @@ gen_Enum_binds tycon nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) @@ -445,7 +446,7 @@ gen_Enum_binds tycon (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) enum_from - = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR tycon), @@ -454,7 +455,7 @@ gen_Enum_binds tycon (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -467,7 +468,7 @@ gen_Enum_binds tycon )) from_enum - = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} @@ -579,8 +580,7 @@ gen_Ix_binds tycon enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] enum_range - = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ @@ -592,7 +592,7 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc unsafeIndex_RDR [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] emptyLHsBinds ( + d_Pat] ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let @@ -605,8 +605,7 @@ gen_Ix_binds tycon ) enum_inRange - = mk_easy_FunBind tycon_loc inRange_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds ( + = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -614,7 +613,7 @@ gen_Ix_binds tycon (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)) ) {-else-} ( false_Expr - ))))) + )))) -------------------------------------------------------------- single_con_ixes @@ -640,7 +639,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] emptyLHsBinds $ + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ nlHsDo ListComp stmts con_expr where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -653,7 +652,7 @@ gen_Ix_binds tycon single_con_index = mk_easy_FunBind tycon_loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] emptyBag + con_pat cs_needed] (mk_index (zip3 as_needed bs_needed cs_needed)) where -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) @@ -675,9 +674,8 @@ gen_Ix_binds tycon single_con_inRange = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] - emptyLHsBinds ( - foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) + 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] @@ -757,9 +755,9 @@ gen_Read_binds get_fixity tycon _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (data_con_str con), - nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))] - Boxed + mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), + nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))] + Boxed read_non_nullary_con data_con = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body] @@ -769,18 +767,21 @@ gen_Read_binds get_fixity tycon | otherwise = prefix_stmts body = result_expr data_con as_needed + con_str = data_con_str data_con prefix_stmts -- T a b c - = [bindLex (ident_pat (data_con_str_w_parens data_con))] + = [bindLex (ident_pat (wrapOpParens con_str))] ++ read_args - infix_stmts -- a %% b - = [read_a1, - bindLex (symbol_pat (data_con_str data_con)), - read_a2] + infix_stmts -- a %% b, or a `T` b + = [read_a1] + ++ (if isSym con_str + then [bindLex (symbol_pat con_str)] + else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]) + ++ [read_a2] lbl_stmts -- T { f1 = a, f2 = b } - = [bindLex (ident_pat (data_con_str_w_parens data_con)), + = [bindLex (ident_pat (wrapOpParens con_str)), read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) ++ [read_punc "}"] @@ -804,12 +805,11 @@ gen_Read_binds get_fixity tycon con_app c as = nlHsVarApps (getRdrName c) as result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as) - punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' - ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo" - symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>" + 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 ">>" - data_con_str con = mkHsString (occNameUserString (getOccName con)) - data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con)) + data_con_str con = occNameString (getOccName con) read_punc c = bindLex (punc_pat c) read_arg a ty @@ -825,16 +825,14 @@ gen_Read_binds get_fixity tycon -- _a = 3 -- or (#) = 4 -- Note the parens! - read_lbl lbl | is_id_start (head lbl_str) - = [bindLex (ident_pat lbl_lit)] - | otherwise + read_lbl lbl | isSym lbl_str = [read_punc "(", - bindLex (symbol_pat lbl_lit), + bindLex (symbol_pat lbl_str), read_punc ")"] + | otherwise + = [bindLex (ident_pat lbl_str)] where - lbl_str = occNameUserString (getOccName lbl) - lbl_lit = mkHsString lbl_str - is_id_start c = isAlpha c || c == '_' + lbl_str = occNameString (getOccName lbl) \end{code} @@ -901,11 +899,12 @@ 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 + con_str = occNameString dc_occ_nm + op_con_str = wrapOpParens con_str + backquote_str = wrapOpBackquotes con_str show_thingies - | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2] + | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] | record_syntax = mk_showString_app (op_con_str ++ " {") : show_record_args ++ [mk_showString_app "}"] | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args @@ -917,7 +916,7 @@ gen_Show_binds get_fixity tycon -- it seems tidier to have them both sides. where occ_nm = getOccName l - nm = occNameUserString_with_parens occ_nm + nm = wrapOpParens (occNameString occ_nm) show_args = zipWith show_arg bs_needed arg_tys (show_arg1:show_arg2:_) = show_args @@ -943,12 +942,17 @@ gen_Show_binds get_fixity tycon 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 +wrapOpParens :: String -> String +wrapOpParens s | isSym s = '(' : s ++ ")" + | otherwise = s + +wrapOpBackquotes :: String -> String +wrapOpBackquotes s | isSym s = s + | otherwise = '`' : s ++ "`" + +isSym :: String -> Bool +isSym "" = False +isSym (c:cs) = startsVarSym c || startsConSym c mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} @@ -994,7 +998,7 @@ gen_Typeable_binds tycon = unitBag $ mk_easy_FunBind tycon_loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function - [nlWildPat] emptyLHsBinds + [nlWildPat] (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where tycon_loc = getSrcSpan tycon @@ -1100,7 +1104,6 @@ gen_Data_binds fix_env tycon tycon_loc dataTypeOf_RDR [nlWildPat] - emptyLHsBinds (nlHsVar data_type_name) ------------ $dT @@ -1125,7 +1128,7 @@ gen_Data_binds fix_env tycon constr_args dc = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag nlHsVar data_type_name, -- DataType - nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name + nlHsLit (mkHsString (occNameString dc_occ)), -- String name nlList labels, -- Field labels nlHsVar fixity] -- Fixity where @@ -1455,7 +1458,7 @@ mk_tc_deriv_name tycon str = mkDerivedRdrName tc_name mk_occ where tc_name = tyConName tycon - mk_occ tc_occ = mkOccFS varName (mkFastString new_str) + mk_occ tc_occ = mkVarOccFS (mkFastString new_str) where new_str = str ++ occNameString tc_occ ++ "#" \end{code}