diff --git a/0001-update-ocamlbrowser-for-4.14.patch b/0001-update-ocamlbrowser-for-4.14.patch new file mode 100644 index 0000000000000000000000000000000000000000..e19c836fb79a2bea29526fedae8785814f68b66e --- /dev/null +++ b/0001-update-ocamlbrowser-for-4.14.patch @@ -0,0 +1,220 @@ +From 0e52cb81271236d904eaf18d26821d5df5e4234a Mon Sep 17 00:00:00 2001 +From: Jacques Garrigue +Date: Wed, 30 Mar 2022 11:12:13 +0900 +Subject: [PATCH] update ocamlbrowser for 4.14 + +--- + Changes | 5 +++++ + browser/searchid.ml | 31 ++++++++++++++----------------- + browser/searchpos.ml | 22 ++++++++++++---------- + browser/typecheck.ml | 2 +- + browser/viewer.ml | 4 ++-- + 5 files changed, 34 insertions(+), 30 deletions(-) + +diff --git a/Changes b/Changes +index 45ba7c8..0fac370 100644 +--- a/Changes ++++ b/Changes +@@ -1,3 +1,8 @@ ++2022-03-30: ++----------- ++* Release labltk-8.06.12 for OCaml 4.14 ++* Update OCamlBrowser ++ + 2021-09-17: + ----------- + * Release labltk-8.06.11 for ocaml 4.13 +diff --git a/browser/searchid.ml b/browser/searchid.ml +index e87852b..ebbf363 100644 +--- a/browser/searchid.ml ++++ b/browser/searchid.ml +@@ -95,27 +95,25 @@ let rec arr p ~card:n = + if p = 0 then 1 else n * arr (p-1) ~card:(n-1) + + let rec all_args ty = +- let ty = repr ty in +- match ty.desc with ++ match get_desc ty with + Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) + | _ -> ([], ty) + + let rec equal ~prefix t1 t2 = +- match (repr t1).desc, (repr t2).desc with ++ match get_desc t1, get_desc t2 with + Tvar _, Tvar _ -> true + | Tvariant row1, Tvariant row2 -> +- let row1 = row_repr row1 and row2 = row_repr row2 in +- let fields1 = filter_row_fields false row1.row_fields +- and fields2 = filter_row_fields false row1.row_fields ++ let fields1 = filter_row_fields false (row_fields row1) ++ and fields2 = filter_row_fields false (row_fields row1) + in + let r1, r2, pairs = merge_row_fields fields1 fields2 in +- row1.row_closed = row2.row_closed && r1 = [] && r2 = [] && ++ row_closed row1 = row_closed row2 && r1 = [] && r2 = [] && + List.for_all pairs ~f: + begin fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None -> true + | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix +- | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> ++ | Reither(c1, tl1, _), Reither(c2, tl2, _) -> + c1 = c2 && List.length tl1 = List.length tl2 && + List.for_all2 tl1 tl2 ~f:(equal ~prefix) + | _ -> false +@@ -143,12 +141,11 @@ let rec equal ~prefix t1 t2 = + let get_options = List.filter ~f:Btype.is_optional + + let rec included ~prefix t1 t2 = +- match (repr t1).desc, (repr t2).desc with ++ match get_desc t1, get_desc t2 with + Tvar _, _ -> true + | Tvariant row1, Tvariant row2 -> +- let row1 = row_repr row1 and row2 = row_repr row2 in +- let fields1 = filter_row_fields false row1.row_fields +- and fields2 = filter_row_fields false row2.row_fields ++ let fields1 = filter_row_fields false (row_fields row1) ++ and fields2 = filter_row_fields false (row_fields row2) + in + let r1, r2, pairs = merge_row_fields fields1 fields2 in + r1 = [] && +@@ -157,7 +154,7 @@ let rec included ~prefix t1 t2 = + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None -> true + | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix +- | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> ++ | Reither(c1, tl1, _), Reither(c2, tl2, _) -> + c1 = c2 && List.length tl1 = List.length tl2 && + List.for_all2 tl1 tl2 ~f:(included ~prefix) + | _ -> false +@@ -207,7 +204,7 @@ let mkpath = function + let get_fields ~prefix ~sign self = + (*let env = open_signature Fresh (mkpath prefix) sign !start_env in*) + let env = add_signature sign !start_env in +- match (expand_head env self).desc with ++ match get_desc (expand_head env self) with + Tobject (ty_obj, _) -> + let l,_ = flatten_fields ty_obj in l + | _ -> [] +@@ -270,12 +267,12 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = + end + + let search_all_types t ~mode = +- let tl = match mode, t.desc with ++ let tl = match mode, get_desc t with + `Exact, _ -> [t] + | `Included, Tarrow _ -> [t] + | `Included, _ -> +- [t; newty(Tarrow(Nolabel,t,newvar(),Cok)); +- newty(Tarrow(Nolabel,newvar(),t,Cok))] ++ [t; newty(Tarrow(Nolabel,t,newvar(),commu_ok)); ++ newty(Tarrow(Nolabel,newvar(),t,commu_ok))] + in List2.flat_map !module_list ~f: + begin fun modname -> + let mlid = Lident modname in +diff --git a/browser/searchpos.ml b/browser/searchpos.ml +index 564e164..2755cdc 100644 +--- a/browser/searchpos.ml ++++ b/browser/searchpos.ml +@@ -195,7 +195,7 @@ let search_pos_type_decl td ~pos ~env = + + let search_pos_extension ext ~pos ~env = + begin match ext.pext_kind with +- Pext_decl (l, _) -> search_pos_arguments l ~pos ~env ++ Pext_decl (_, l, _) -> search_pos_arguments l ~pos ~env + | Pext_rebind _ -> () + end + +@@ -502,16 +502,18 @@ and view_module_id id ~env = + and view_type_decl path ~env = + let td = find_type path env in + try match td.type_manifest with None -> raise Not_found +- | Some ty -> match (Ctype.repr ty).desc with ++ | Some ty -> match get_desc ty with + Tobject _ -> + let clt = find_cltype path env in + view_signature_item ~path ~env + [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first, + Exported); + dummy_item; dummy_item] +- | Tvariant ({row_name = Some _} as row) -> +- let td = {td with type_manifest = Some( +- Btype.newgenty (Tvariant {row with row_name = None}))} in ++ | Tvariant row when row_name row <> None -> ++ let Row {fields; more; closed; fixed} = row_repr row in ++ let row = create_row ~fields ~more ~closed ~fixed ~name:None in ++ let td = ++ {td with type_manifest = Some(Btype.newgenty (Tvariant row))} in + view_signature_item ~path ~env + [Sig_type(ident_of_path path ~default:"t", td, Trec_first, + Exported)] +@@ -697,8 +699,7 @@ let view_type_menu kind ~env ~parent = + Format.set_formatter_output_functions buf#out ignore; + Format.set_margin 60; + Format.open_hbox (); +- Printtyp.reset (); +- Printtyp.mark_loops ty; ++ Printtyp.prepare_for_printing [ty]; + Printtyp.wrap_printing_env ~error:false env + (fun () -> Printtyp.type_expr Format.std_formatter ty); + Format.close_box (); Format.print_flush (); +@@ -712,11 +713,12 @@ let view_type_menu kind ~env ~parent = + in + (* Menu.add_separator menu; *) + List.iter l ~f: +- begin fun label -> match (Ctype.repr ty).desc with ++ begin fun label -> match get_desc ty with + Tconstr (path,_,_) -> + Menu.add_command menu ~label ~font + ~command:(fun () -> view_type_decl path ~env) +- | Tvariant {row_name = Some (path, _)} -> ++ | Tvariant row when row_name row <> None -> ++ let path, _ = Stdlib.Option.get (row_name row) in + Menu.add_command menu ~label ~font + ~command:(fun () -> view_type_decl path ~env) + | _ -> +@@ -864,7 +866,7 @@ and search_pos_expr ~pos exp = + search_pos_expr a ~pos; search_pos_expr b ~pos + | Texp_for (_, _, a, b, _, c) -> + List.iter [a;b;c] ~f:(search_pos_expr ~pos) +- | Texp_send (exp, _, _) -> search_pos_expr exp ~pos ++ | Texp_send (exp, _) -> search_pos_expr exp ~pos + | Texp_new (path, _, _) -> + add_found_str (`Exp(`New path, exp.exp_type)) + ~env:exp.exp_env ~loc:exp.exp_loc +diff --git a/browser/typecheck.ml b/browser/typecheck.ml +index 99ef48a..e6c4261 100644 +--- a/browser/typecheck.ml ++++ b/browser/typecheck.ml +@@ -116,7 +116,7 @@ let f txt = + List.iter psl ~f: + begin function + Ptop_def pstr -> +- let str, sign, _names, env' = Typemod.type_structure !env pstr in ++ let str, sign, _names, _, env' = Typemod.type_structure !env pstr in + txt.structure <- txt.structure @ str.str_items; + txt.signature <- txt.signature @ sign; + env := env' +diff --git a/browser/viewer.ml b/browser/viewer.ml +index 590da6f..7c96707 100644 +--- a/browser/viewer.ml ++++ b/browser/viewer.ml +@@ -65,13 +65,13 @@ let view_symbol ~kind ~env ?path id = + [Sig_value (Ident.create_local name, vd, Exported)] + | Ptype -> view_type_id id ~env + | Plabel -> let ld = find_label_by_name id env in +- begin match ld.lbl_res.desc with ++ begin match get_desc ld.lbl_res with + Tconstr (path, _, _) -> view_type_decl path ~env + | _ -> () + end + | Pconstructor -> + let cd = find_constructor_by_name id env in +- begin match cd.cstr_tag, cd.cstr_res.desc with ++ begin match cd.cstr_tag, get_desc cd.cstr_res with + Cstr_extension _, Tconstr (cpath, args, _) -> + view_signature ~title:(string_of_longident id) ~env ?path + [Sig_typext (Ident.create_local name, +-- +2.42.0.windows.2 + diff --git a/labltk.spec b/labltk.spec index 82a82e0757cc6cf680cf221016380b189e138b4c..2ecb1b4ff1fb17a9bdfcda3988e3bfcb17f34569 100644 --- a/labltk.spec +++ b/labltk.spec @@ -5,7 +5,7 @@ %endif Name: ocaml-labltk Version: 8.06.11 -Release: 1 +Release: 2 Summary: Tcl/Tk interface for OCaml License: LGPLv2+ with exceptions URL: https://github.com/garrigue/labltk @@ -13,6 +13,9 @@ Source0: https://github.com/garrigue/labltk/archive/%{version}/lablt # This adds debugging (-g) everywhere. Patch1: labltk-8.06.11-enable-debugging.patch BuildRequires: ocaml tcl-devel tk-devel + +Patch0002: 0001-update-ocamlbrowser-for-4.14.patch + %description labltk or mlTk is a library for interfacing OCaml with the scripting language Tcl/Tk (all versions since 8.0.3, but no betas). @@ -28,6 +31,7 @@ This package contains the development files. %prep %setup -q -n labltk-%{version} %patch1 -p1 +%patch0002 -p1 find -name .gitignore -delete find -type f | xargs sed -i -e 's/-warn-error/-w/g' @@ -79,6 +83,9 @@ install -m 0644 camltk/*.o $RPM_BUILD_ROOT%{_libdir}/ocaml/labltk %{_libdir}/ocaml/labltk/*.mli %changelog +* Wed Jan 31 2024 liubo - -8.06.11-2 +- update ocamlbrowser for 4.14 + * Thu Jan 20 2022 liyanan -8.06.11-1 - update to 8.06.11