From 2ba923757b6015176b27e4b6296b06bf9b757056 Mon Sep 17 00:00:00 2001 From: Florian Angeletti Date: Thu, 9 Oct 2025 16:36:11 +0200 Subject: [PATCH] Update for 5.4 --- CHANGES.md | 5 +++ src/compat/gen.ml | 5 ++- src/compat/longident_ge_000.ml | 2 ++ src/compat/longident_ge_504.ml | 2 ++ src/compat/tuple_ge_000.ml | 2 ++ src/compat/tuple_ge_504.ml | 2 ++ src/ppx_import.ml | 44 +++++++++++++----------- src_test/ppx_deriving/test_ppx_import.ml | 11 +++++- 8 files changed, 50 insertions(+), 23 deletions(-) create mode 100644 src/compat/longident_ge_000.ml create mode 100644 src/compat/longident_ge_504.ml create mode 100644 src/compat/tuple_ge_000.ml create mode 100644 src/compat/tuple_ge_504.ml diff --git a/CHANGES.md b/CHANGES.md index 35b9422..ad36bad 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -14,6 +14,11 @@ Unreleased type%import loc = Location.t ``` + * Support for OCaml 5.4 (???, @octachron) + +1.11.0 +------ + * Support for OCaml 5.2 (#94, @kit-ty-kate) 1.10.0 diff --git a/src/compat/gen.ml b/src/compat/gen.ml index 9a6c75a..30997bb 100644 --- a/src/compat/gen.ml +++ b/src/compat/gen.ml @@ -17,7 +17,10 @@ let include_table = ; ("types_type_kind", [(5, 2); (4, 13)]) ; ("init_path", [(4, 9)]) ; ("env_lookup", [(4, 10)]) - ; ("types_desc", [(4, 14)]) ] + ; ("types_desc", [(4, 14)]) + ; ("tuple", [5,4]) + ; ("longident", [5,4]) + ] let rec gen_compat real_version (f_prefix, version_list) = match version_list with diff --git a/src/compat/longident_ge_000.ml b/src/compat/longident_ge_000.ml new file mode 100644 index 0000000..09a8752 --- /dev/null +++ b/src/compat/longident_ge_000.ml @@ -0,0 +1,2 @@ +let longident_inj x = x +let longident_proj x = x diff --git a/src/compat/longident_ge_504.ml b/src/compat/longident_ge_504.ml new file mode 100644 index 0000000..2e82333 --- /dev/null +++ b/src/compat/longident_ge_504.ml @@ -0,0 +1,2 @@ +let longident_inj = Location.mknoloc +let longident_proj x = x.Location.txt diff --git a/src/compat/tuple_ge_000.ml b/src/compat/tuple_ge_000.ml new file mode 100644 index 0000000..1694863 --- /dev/null +++ b/src/compat/tuple_ge_000.ml @@ -0,0 +1,2 @@ +let tuple f xs = + Ppxlib.Ast_helper.Typ.tuple (List.map (fun x -> f x) xs) diff --git a/src/compat/tuple_ge_504.ml b/src/compat/tuple_ge_504.ml new file mode 100644 index 0000000..7b74c6a --- /dev/null +++ b/src/compat/tuple_ge_504.ml @@ -0,0 +1,2 @@ +let tuple f xs = + Ppxlib.Ast_helper.Typ.tuple (List.map (fun (_,x) -> f x) xs) diff --git a/src/ppx_import.ml b/src/ppx_import.ml index c7700fc..27dbc6c 100644 --- a/src/ppx_import.ml +++ b/src/ppx_import.ml @@ -33,14 +33,17 @@ let lazy_env = Compat.init_path (); Ocaml_common.Compmisc.initial_env () ) -let string_of_lid lid = - let rec print lid acc = - match lid with - | Longident.Lident s -> s :: acc - | Longident.Ldot (lid, id) -> print lid ("." :: id :: acc) - | Longident.Lapply (la, lb) -> print la ("(" :: print lb (")" :: acc)) - in - String.concat "" (print lid []) +let string_of_lid' lid = Format.asprintf "%a" Pprintast.longident lid +let string_of_lid lid = Format.asprintf "%a" Astlib.Pprintast.longident lid + +(* Remove locations *) +let rec longident_without_loc = + let proj x = Compat.longident_proj x in + let conv x = longident_without_loc (proj x) in + function + | Longident.Ldot (x,y) -> Astlib.Longident.Ldot (conv x, proj y) + | Longident.Lapply (f,x) -> Astlib.Longident.Lapply (conv f, conv x) + | Longident.Lident x -> Astlib.Longident.Lident x let try_find_module ~loc env lid = (* Note: we are careful to call `Env.lookup_module` and not @@ -75,7 +78,7 @@ let try_find_module_type ~loc env lid = let error = Printf.sprintf "[%%import]: cannot access the signature of the abstract module %s" - (string_of_lid lid) + (string_of_lid' lid) in raise_error ~loc error | Some module_type -> module_type ) @@ -106,7 +109,7 @@ let locate_sig ~loc env lid = let head, path = try match Ppxlib.Longident.flatten_exn lid with - | head :: path -> (Longident.Lident head, path) + | head :: path -> (head, path) | _ -> assert false with Invalid_argument _ -> let error = @@ -115,9 +118,9 @@ let locate_sig ~loc env lid = in raise_error ~loc error in + let chead = Longident.Lident head in let head_module_type = - match - (try_find_module ~loc env head, lazy (try_find_module_type ~loc env head)) + match (try_find_module ~loc env chead, lazy (try_find_module_type ~loc env chead)) with | Some mty, _ -> mty | None, (lazy (Some mty)) -> mty @@ -147,10 +150,10 @@ let locate_sig ~loc env lid = let sub_module_type = loop (List.map Compat.migrate_signature_item sig_items) in - (Longident.Ldot (lid, path_item), sub_module_type) + (Astlib.Longident.Ldot(lid,path_item), sub_module_type) in let _lid, sub_module_type = - List.fold_left get_sub_module_type (head, head_module_type) path + List.fold_left get_sub_module_type (Astlib.Longident.Lident head, head_module_type) path in open_module_type ~loc env lid sub_module_type @@ -193,7 +196,7 @@ let get_modtype_decl ~loc sig_items parent_lid elem = raise_error ~loc error | Some decl -> decl -let longident_of_path = Untypeast.lident_of_path +let longident_of_path x = longident_without_loc (Untypeast.lident_of_path x) let mknoloc (txt : 'a) : 'a Ppxlib.Location.loc = {txt; loc = Ppxlib.Location.none} @@ -216,8 +219,7 @@ let rec core_type_of_type_expr ~subst (type_expr : Ocaml_common.Types.type_expr) | _ -> lhs in Ppxlib.Ast_helper.Typ.arrow label lhs (core_type_of_type_expr ~subst rhs) - | Ttuple xs -> - Ppxlib.Ast_helper.Typ.tuple (List.map (core_type_of_type_expr ~subst) xs) + | Ttuple xs -> Compat.tuple (core_type_of_type_expr ~subst) xs | Tconstr (path, args, _) -> ( let lid = longident_of_path path in let args = List.map (core_type_of_type_expr ~subst) args in @@ -426,11 +428,11 @@ let type_declaration ~tool_name ~input_name (type_decl : Ppxlib.type_declaration (string_of_lid lid) in raise_error ~loc error - | Lident _ as head_id -> + | Lident hid -> (* In this case, we know for sure that the user intends this lident as a type name, so we use Typetexp.find_type and let the failure cases propagate to the user. *) - Compat.find_type env ~loc head_id |> snd + Compat.find_type env ~loc (Lident hid) |> snd | Ldot (parent_id, elem) -> let sig_items = locate_sig ~loc env parent_id in get_type_decl ~loc sig_items parent_id elem @@ -531,11 +533,11 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) = (string_of_lid lid) in raise_error ~loc error - | Longident.Lident _ as head_id -> + | Longident.Lident head_id -> (* In this case, we know for sure that the user intends this lident as a module type name, so we use Typetexp.find_type and let the failure cases propagate to the user. *) - Compat.find_modtype env ~loc head_id |> snd + Compat.find_modtype env ~loc (Lident head_id) |> snd | Longident.Ldot (parent_id, elem) -> let sig_items = locate_sig ~loc env parent_id in get_modtype_decl ~loc sig_items parent_id elem diff --git a/src_test/ppx_deriving/test_ppx_import.ml b/src_test/ppx_deriving/test_ppx_import.ml index b8ad8db..3e4cf62 100644 --- a/src_test/ppx_deriving/test_ppx_import.ml +++ b/src_test/ppx_deriving/test_ppx_import.ml @@ -40,6 +40,12 @@ module Test_optional : S_optional = struct let f ?(opt = 0) () = ignore opt end +module Location = struct + type t = Location.t + let pp = Location.print_loc + [%%import type 'a loc = 'a Location.loc [@@deriving show]] +end + [%%import: type longident = Longident.t [@@deriving show]] [%%import: @@ -49,9 +55,12 @@ type package_type = core_type := (Parsetree.core_type [@printer Pprintast.core_type]); Asttypes.loc := (Asttypes.loc [@polyprinter fun pp fmt x -> pp fmt x.Asttypes.txt]); - Longident.t := (Longident.t [@printer pp_longident])] ) + Longident.t := (Longident.t [@printer pp_longident]); + attributes := (Parsetree.attributes [@printer (fun _ _ -> ())]) + ]) [@@deriving show]] + module type Hashable = [%import: (module Hashtbl.HashedType)] [%%import: type self_t = Test_self_import.t]