From 2e71c220240ee226f44bd5b9463eccfad39486e7 Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Tue, 27 Jan 2026 18:50:22 +0100 Subject: [PATCH 01/25] Update for dune 3.21 --- dune-project | 2 +- odoc-bench.opam | 2 +- odoc-driver.opam | 2 +- odoc-md.opam | 2 +- odoc-parser.opam | 2 +- odoc.opam | 2 +- sherlodoc.opam | 2 +- sherlodoc/test/cram/{empty.t => empty_project.t}/dune | 0 sherlodoc/test/cram/{empty.t => empty_project.t}/dune-project | 0 sherlodoc/test/cram/{empty.t => empty_project.t}/foo.ml | 0 sherlodoc/test/cram/{empty.t => empty_project.t}/run.t | 0 sherlodoc/test/cram_ancient/{empty.t => empty_project.t} | 0 12 files changed, 7 insertions(+), 7 deletions(-) rename sherlodoc/test/cram/{empty.t => empty_project.t}/dune (100%) rename sherlodoc/test/cram/{empty.t => empty_project.t}/dune-project (100%) rename sherlodoc/test/cram/{empty.t => empty_project.t}/foo.ml (100%) rename sherlodoc/test/cram/{empty.t => empty_project.t}/run.t (100%) rename sherlodoc/test/cram_ancient/{empty.t => empty_project.t} (100%) diff --git a/dune-project b/dune-project index 37448f6218..1522a5441d 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.18) +(lang dune 3.21) (name odoc) diff --git a/odoc-bench.opam b/odoc-bench.opam index d412a09a23..214cf67c5e 100644 --- a/odoc-bench.opam +++ b/odoc-bench.opam @@ -31,7 +31,7 @@ depends: [ "astring" "cmdliner" {>= "1.3.0"} "cppo" {build & >= "1.1.0"} - "dune" {>= "3.18.0"} + "dune" {>= "3.21.0"} "fpath" "ocaml" {>= "4.02.0"} "result" diff --git a/odoc-driver.opam b/odoc-driver.opam index 173e9833f7..1a7d4ff182 100644 --- a/odoc-driver.opam +++ b/odoc-driver.opam @@ -35,7 +35,7 @@ documentation for installed packages. depends: [ "ocaml" {>= "5.1.0"} "odoc" {= version} - "dune" {>= "3.18.0"} + "dune" {>= "3.21.0"} "odoc-md" "bos" "fpath" {>= "0.7.3"} diff --git a/odoc-md.opam b/odoc-md.opam index 0ebfc20139..8d9db93937 100644 --- a/odoc-md.opam +++ b/odoc-md.opam @@ -28,7 +28,7 @@ This package provides support for generating documentation from Markdown files. depends: [ "ocaml" {>= "4.14.0"} "odoc" {= version} - "dune" {>= "3.18.0"} + "dune" {>= "3.21.0"} "cmdliner" {>= "1.3.0"} "cmarkit" ] diff --git a/odoc-parser.opam b/odoc-parser.opam index de29feca3c..92935df19a 100644 --- a/odoc-parser.opam +++ b/odoc-parser.opam @@ -13,7 +13,7 @@ bug-reports: "https://github.com/ocaml/odoc/issues" dev-repo: "git+https://github.com/ocaml/odoc.git" doc: "https://ocaml.github.io/odoc/odoc_parser" depends: [ - "dune" {>= "3.18"} + "dune" {>= "3.21"} "ocaml" {>= "4.08.0" & < "5.5"} "astring" "camlp-streams" diff --git a/odoc.opam b/odoc.opam index fc572c6600..62478fe47c 100644 --- a/odoc.opam +++ b/odoc.opam @@ -43,7 +43,7 @@ depends: [ "astring" "cmdliner" {>= "1.3.0"} "cppo" {build & >= "1.1.0"} - "dune" {>= "3.18.0"} + "dune" {>= "3.21.0"} "fpath" {>= "0.7.3"} "ocaml" {>= "4.08.0" & < "5.5"} "tyxml" {>= "4.4.0"} diff --git a/sherlodoc.opam b/sherlodoc.opam index 9c2eebbfd1..e3dd729379 100644 --- a/sherlodoc.opam +++ b/sherlodoc.opam @@ -8,7 +8,7 @@ homepage: "https://github.com/ocaml/odoc" doc: "https://ocaml.github.io/odoc/" bug-reports: "https://github.com/ocaml/odoc/issues" depends: [ - "dune" {>= "3.18"} + "dune" {>= "3.21"} "ocaml" {>= "4.0.8"} "odoc" {= version} "base64" {>= "3.5.1"} diff --git a/sherlodoc/test/cram/empty.t/dune b/sherlodoc/test/cram/empty_project.t/dune similarity index 100% rename from sherlodoc/test/cram/empty.t/dune rename to sherlodoc/test/cram/empty_project.t/dune diff --git a/sherlodoc/test/cram/empty.t/dune-project b/sherlodoc/test/cram/empty_project.t/dune-project similarity index 100% rename from sherlodoc/test/cram/empty.t/dune-project rename to sherlodoc/test/cram/empty_project.t/dune-project diff --git a/sherlodoc/test/cram/empty.t/foo.ml b/sherlodoc/test/cram/empty_project.t/foo.ml similarity index 100% rename from sherlodoc/test/cram/empty.t/foo.ml rename to sherlodoc/test/cram/empty_project.t/foo.ml diff --git a/sherlodoc/test/cram/empty.t/run.t b/sherlodoc/test/cram/empty_project.t/run.t similarity index 100% rename from sherlodoc/test/cram/empty.t/run.t rename to sherlodoc/test/cram/empty_project.t/run.t diff --git a/sherlodoc/test/cram_ancient/empty.t b/sherlodoc/test/cram_ancient/empty_project.t similarity index 100% rename from sherlodoc/test/cram_ancient/empty.t rename to sherlodoc/test/cram_ancient/empty_project.t From 1d9c0943ee2a1c2b3e56c11983759ee79d0256be Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 07:08:37 -0400 Subject: [PATCH 02/25] Quick fix for `include functor` (#1) --- src/loader/cmt.ml | 7 +++++-- src/loader/cmti.ml | 5 +++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 3f5cf998bf..f78c73b97c 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -569,10 +569,13 @@ and read_include env parent incl = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in let decl_modty = - match unwrap_module_expr_desc incl.incl_mod.mod_desc with - | Tmod_ident(p, _) -> + match unwrap_module_expr_desc incl.incl_mod.mod_desc, incl.incl_kind with + | Tmod_ident(p, _), Tincl_structure -> let p = Env.Path.read_module env.ident_env p in Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)) + | _, (Tincl_functor _ | Tincl_gen_functor _) -> + (* TODO: Handle [include functor] *) + None | _ -> let mty = read_module_expr env parent container incl.incl_mod in umty_of_mty mty diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index ba44f115ad..67281a5d91 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -780,11 +780,12 @@ and read_include env parent incl = let expr = read_module_type env parent container incl.incl_mod in let umty = Odoc_model.Lang.umty_of_mty expr in let expansion = { content; shadowed; } in - match umty with - | Some uexpr -> + match umty, incl.incl_kind with + | Some uexpr, Tincl_structure -> let decl = Include.ModuleType uexpr in [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] | _ -> + (* TODO: Handle [include functor] *) content.items and read_open env parent o = From 011d4f3377ab46dd73f05d7a7d2cdcf3d5548d1a Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 07:13:56 -0400 Subject: [PATCH 03/25] Support OxCaml `Compilation_unit.t` type (#2) --- src/loader/odoc_loader.ml | 29 ++++++++++++++++++++++++----- src/model/compat.cppo.ml | 2 +- src/odoc/depends.ml | 4 +++- test/xref2/lib/common.cppo.ml | 9 ++++++--- 4 files changed, 34 insertions(+), 10 deletions(-) diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index b3810f456b..9c1ad7a88a 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -112,7 +112,7 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = try Odoc_model.Names.set_unique_ident (Digest.to_hex digest) with _ -> () in - let name = cmt_info.cmt_modname in + let name = cmt_info.cmt_modname |> Compilation_unit.name_as_string in let sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, @@ -121,7 +121,12 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = let id, sg, canonical = Cmti.read_interface parent name ~warnings_tag intf in - compilation_unit_of_sig ~make_root ~imports:cmt_info.cmt_imports + let imports = + cmt_info.cmt_imports + |> List.map (fun (name, info_opt) -> + name |> Compilation_unit.Name.to_string, Option.map snd info_opt) + in + compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile ~name ~id ?canonical sg) | _ -> raise Not_an_interface @@ -130,7 +135,7 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = | exception Cmi_format.Error (Not_an_interface _) -> raise Not_an_implementation | cmt_info -> ( - let name = cmt_info.cmt_modname in + let name = cmt_info.cmt_modname |> Compilation_unit.name_as_string in let sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, @@ -147,7 +152,12 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = | Some digest -> ( try Odoc_model.Names.set_unique_ident (Digest.to_hex digest) with _ -> ())); - let imports = cmt_info.cmt_imports in + let imports = + cmt_info.cmt_imports + |> List.map (fun (name, info_opt) -> + name |> Compilation_unit.Name.to_string, + Option.map snd info_opt) + in match cmt_info.cmt_annots with | Packed (_, files) -> let id = @@ -187,11 +197,20 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = let read_cmi ~make_root ~parent ~filename ~warnings_tag () = let cmi_info = Cmi_format.read_cmi filename in match cmi_info.cmi_crcs with - | (name, (Some _ as interface)) :: imports when name = cmi_info.cmi_name -> + | (name, (Some _ as interface)) :: imports + when name = cmi_info.cmi_name -> + let name = name |> Compilation_unit.Name.to_string in let id, sg = Cmi.read_interface parent name ~warnings_tag (Odoc_model.Compat.signature cmi_info.cmi_sign) in + let imports = + imports + |> List.map (fun (name, info_opt) -> + name |> Compilation_unit.Name.to_string, + Option.map snd info_opt) + in + let interface = interface |> Option.map snd in compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id sg | _ -> raise Corrupted diff --git a/src/model/compat.cppo.ml b/src/model/compat.cppo.ml index b5e528955b..8096de8150 100644 --- a/src/model/compat.cppo.ml +++ b/src/model/compat.cppo.ml @@ -274,7 +274,7 @@ let shape_info_of_cmt_infos : Cmt_format.cmt_infos -> (shape * uid_to_loc) optio #endif #if OCAML_VERSION >= (5,2,0) -let compunit_name : Cmo_format.compunit -> string = function | Compunit x -> x +let compunit_name : Compilation_unit.t -> string = Compilation_unit.name_as_string let required_compunit_names x = List.map compunit_name x.Cmo_format.cu_required_compunits diff --git a/src/odoc/depends.ml b/src/odoc/depends.ml index d1eb392431..f0dbdedcc1 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -37,7 +37,9 @@ module Compile_set = Set.Make (Compile) let add_dep acc = function | _, None -> acc (* drop module aliases *) - | unit_name, Some digest -> Compile_set.add { Compile.unit_name; digest } acc + | unit_name, Some (_unit, digest) -> + let unit_name = unit_name |> Compilation_unit.Name.to_string in + Compile_set.add { Compile.unit_name; digest } acc let for_compile_step_cmt acc file = let cmt_infos = Cmt_format.read_cmt (Fs.File.to_string file) in diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index c716cb42f8..0c07b94293 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -18,6 +18,9 @@ utop # Resolve.signature Env.empty sg let _ = Toploop.set_paths () +let dummy_compilation_unit = Compilation_unit.of_string "" +let dummy_unit_info = Unit_info.make_dummy ~input_name:"" dummy_compilation_unit + let cmti_of_string s = Odoc_xref2.Tools.reset_caches (); let env = Compmisc.initial_env () in @@ -27,6 +30,8 @@ let cmti_of_string s = #if OCAML_VERSION >= (4,4,0) && OCAML_VERSION < (4,9,0) "" #endif + ~sourcefile:"" + dummy_compilation_unit env p;; let cmt_of_string s = @@ -35,10 +40,8 @@ let cmt_of_string s = let p = Parse.implementation l in #if OCAML_VERSION < (5,2,0) Typemod.type_implementation "" "" "" env p -#elif OCAML_VERSION < (5,3,0) - Typemod.type_implementation (Unit_info.make ~source_file:"" "") env p #else - Typemod.type_implementation Unit_info.(make ~source_file:"" Impl "") env p + Typemod.type_implementation dummy_unit_info dummy_compilation_unit env p #endif let parent = Odoc_model.Paths.Identifier.Mk.page (None, PageName.make_std "None") From 86397b630632b4ef6faf6389086f9b1db120af21 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 07:17:53 -0400 Subject: [PATCH 04/25] Support OxCaml `Import_info.t` type (#3) --- src/loader/odoc_loader.ml | 38 ++++++++++++++++++++++++++--------- src/model/compat.cppo.ml | 4 ++-- src/odoc/classify.cppo.ml | 42 +++++++++++++++++++++++++++++---------- src/odoc/depends.ml | 12 ++++++++--- 4 files changed, 72 insertions(+), 24 deletions(-) diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index 9c1ad7a88a..164c1af8c8 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -123,8 +123,10 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = in let imports = cmt_info.cmt_imports - |> List.map (fun (name, info_opt) -> - name |> Compilation_unit.Name.to_string, Option.map snd info_opt) + |> Array.map (fun import -> + Import_info.name import |> Compilation_unit.Name.to_string, + Import_info.crc import) + |> Array.to_list in compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile ~name ~id ?canonical sg) @@ -154,9 +156,10 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = with _ -> ())); let imports = cmt_info.cmt_imports - |> List.map (fun (name, info_opt) -> - name |> Compilation_unit.Name.to_string, - Option.map snd info_opt) + |> Array.map (fun import -> + Import_info.name import |> Compilation_unit.Name.to_string, + Import_info.crc import) + |> Array.to_list in match cmt_info.cmt_annots with | Packed (_, files) -> @@ -194,9 +197,20 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = ~name ~id ?canonical sg | _ -> raise Not_an_implementation) +let compilation_unit_of_import_info (info : Import_info.Intf.Nonalias.t option) = + match info with + | None -> None + | Some (Parameter, _) -> None + | Some (Normal cu, _) -> Some (cu |> Compilation_unit.full_path_as_string) + let read_cmi ~make_root ~parent ~filename ~warnings_tag () = let cmi_info = Cmi_format.read_cmi filename in - match cmi_info.cmi_crcs with + let cmi_crcs = + List.map (fun import -> + Import_info.name import, Import_info.Intf.info import) + (Array.to_list cmi_info.cmi_crcs) + in + match cmi_crcs with | (name, (Some _ as interface)) :: imports when name = cmi_info.cmi_name -> let name = name |> Compilation_unit.Name.to_string in @@ -208,7 +222,7 @@ let read_cmi ~make_root ~parent ~filename ~warnings_tag () = imports |> List.map (fun (name, info_opt) -> name |> Compilation_unit.Name.to_string, - Option.map snd info_opt) + compilation_unit_of_import_info info_opt) in let interface = interface |> Option.map snd in compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id sg @@ -219,14 +233,20 @@ let read_impl ~make_root ~filename ~source_id () = | exception Cmi_format.Error (Not_an_interface _) -> raise Not_an_implementation | cmt_info -> ( - let name = cmt_info.cmt_modname in + let name = cmt_info.cmt_modname |> Compilation_unit.name_as_string in let _sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, cmt_info.cmt_builddir ) in let interface = cmt_info.cmt_interface_digest in - let imports = cmt_info.cmt_imports in + let imports = + cmt_info.cmt_imports + |> Array.map (fun import -> + Import_info.name import |> Compilation_unit.Name.to_string, + Import_info.crc import) + |> Array.to_list + in match cmt_info.cmt_annots with | Implementation _impl -> let digest = diff --git a/src/model/compat.cppo.ml b/src/model/compat.cppo.ml index 8096de8150..106a966cdf 100644 --- a/src/model/compat.cppo.ml +++ b/src/model/compat.cppo.ml @@ -280,9 +280,9 @@ let required_compunit_names x = List.map compunit_name x.Cmo_format.cu_required_ #elif OCAML_VERSION >= (4,04,0) -let compunit_name x = x +let compunit_name x = Compilation_unit.name_as_string x -let required_compunit_names x = List.map Ident.name x.Cmo_format.cu_required_globals +let required_compunit_names x = List.map compunit_name x.Cmo_format.cu_required_globals #else diff --git a/src/odoc/classify.cppo.ml b/src/odoc/classify.cppo.ml index 417bf817ef..ffbc8648d3 100644 --- a/src/odoc/classify.cppo.ml +++ b/src/odoc/classify.cppo.ml @@ -15,6 +15,9 @@ let debug = ref false let log fmt = if !debug then Format.printf fmt else Format.ifprintf Format.std_formatter fmt +let name_of_import import = + Import_info.name import |> Compilation_unit.Name.to_string + module Archive = struct type name = string @@ -46,8 +49,8 @@ module Archive = struct modules = StringSet.add (Odoc_model.Compat.compunit_name cu.cu_name) lib.modules; intf_deps = - List.fold_left - (fun deps (cu, _) -> StringSet.add cu deps) + Array.fold_left + (fun deps import -> StringSet.add (name_of_import import) deps) lib.intf_deps cu.cu_imports; impl_deps = List.fold_left @@ -56,19 +59,20 @@ module Archive = struct (Odoc_model.Compat.required_compunit_names cu); } - let add_unit_info lib (unit_info : Cmx_format.unit_infos) = + let add_unit_info lib (unit, cmis, cmxs) = + let name = unit |> Compilation_unit.name_as_string in normalise { lib with - modules = StringSet.add unit_info.ui_name lib.modules; + modules = StringSet.add name lib.modules; intf_deps = List.fold_left - (fun deps (unit_info, _) -> StringSet.add unit_info deps) - lib.intf_deps unit_info.ui_imports_cmi; + (fun deps import -> StringSet.add (name_of_import import) deps) + lib.intf_deps cmis; impl_deps = List.fold_left - (fun deps (name, _) -> StringSet.add name deps) - lib.impl_deps unit_info.ui_imports_cmx; + (fun deps import -> StringSet.add (name_of_import import) deps) + lib.impl_deps cmxs; } let add_module_by_name lib name = @@ -96,7 +100,7 @@ module Cmi = struct let get_deps filename = let cmi, _cmt = Cmt_format.read filename in match cmi with - | Some cmi -> List.map fst cmi.Cmi_format.cmi_crcs |> StringSet.of_list + | Some cmi -> Array.map name_of_import cmi.Cmi_format.cmi_crcs |> Array.to_seq |> StringSet.of_seq | None -> StringSet.empty end @@ -166,7 +170,25 @@ let read_cma ic init = let read_cmxa ic init = let li = (input_value ic : Cmx_format.library_infos) in close_in ic; - Ok (List.fold_left Archive.add_unit_info init (List.map fst li.lib_units)) + (* FIXME: This OxCaml-specific code is awful and can be gotten rid of + once this PR (which was inspired by having to write this very code) is merged: + https://github.com/oxcaml/oxcaml/pull/2673 *) + let get_masked array i ~mask = + if Misc.Bitmap.get mask i then Some (Array.get array i) else None + in + let bitmap_to_list b ~array = + List.init (Array.length array) (fun i -> i) + |> List.filter_map (fun i -> get_masked array i ~mask:b) + in + let units = + List.map + (fun (unit : Cmx_format.lib_unit_info) -> + let cmis = bitmap_to_list unit.li_imports_cmi ~array:li.lib_imports_cmi in + let cmxs = bitmap_to_list unit.li_imports_cmx ~array:li.lib_imports_cmx in + unit.li_name, cmis, cmxs) + li.lib_units + in + Ok (List.fold_left Archive.add_unit_info init units) #if OCAML_VERSION >= (4, 12, 0) open Misc diff --git a/src/odoc/depends.ml b/src/odoc/depends.ml index f0dbdedcc1..87e9c56765 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -35,19 +35,25 @@ end module Compile_set = Set.Make (Compile) -let add_dep acc = function +let add_dep0 acc (unit_name, crc_with_unit) = + match unit_name, crc_with_unit with | _, None -> acc (* drop module aliases *) | unit_name, Some (_unit, digest) -> let unit_name = unit_name |> Compilation_unit.Name.to_string in Compile_set.add { Compile.unit_name; digest } acc +let add_dep acc import = + let unit_name = Import_info.name import in + let crc_with_unit = Import_info.Intf.info import in + add_dep0 acc (unit_name, crc_with_unit) + let for_compile_step_cmt acc file = let cmt_infos = Cmt_format.read_cmt (Fs.File.to_string file) in - List.fold_left ~f:add_dep ~init:acc cmt_infos.Cmt_format.cmt_imports + Array.fold_left ~f:add_dep ~init:acc cmt_infos.Cmt_format.cmt_imports let for_compile_step_cmi_or_cmti acc file = let cmi_infos = Cmi_format.read_cmi (Fs.File.to_string file) in - List.fold_left ~f:add_dep ~init:acc cmi_infos.Cmi_format.cmi_crcs + Array.fold_left ~f:add_dep ~init:acc cmi_infos.Cmi_format.cmi_crcs let for_compile_step files = let set = From 96ed1d8a1a433f51662b46b6679749666cc096e4 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 07:21:22 -0400 Subject: [PATCH 05/25] Support OxCaml polymorphic arguments (#4) --- src/loader/cmi.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 53bbc7ac3b..db6791aafb 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -467,11 +467,18 @@ let rec read_type_expr env typ = let lbl,arg = match lbl with | Some (Optional s) -> ( + let read_as_wrapped () = + (Some (RawOptional s), read_type_expr env arg) + in match Compat.get_desc arg with - | Tconstr(_option, [arg], _) -> - lbl, read_type_expr env arg (* Unwrap option if possible *) + | Tpoly(arg, []) -> begin + match Compat.get_desc arg with + | Tconstr(_option, [arg], _) -> + lbl, read_type_expr env arg (* Unwrap option if possible *) + | _ -> read_as_wrapped () + end | _ -> - (Some (RawOptional s), read_type_expr env arg)) (* If not, mark is as wrapped *) + read_as_wrapped ()) (* If not, mark is as wrapped *) | _ -> lbl, read_type_expr env arg in From 7b12dd2ed6c7da791aef8faeaf93ee1f81589f13 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 07:24:37 -0400 Subject: [PATCH 06/25] Adapt to OxCaml renaming `Ident.persistent` (#5) --- src/loader/ident_env.cppo.ml | 2 +- src/loader/implementation.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 805728d475..09cb3c4af0 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -683,7 +683,7 @@ let is_shadowed module Path = struct let read_module_ident env id = - if Ident.persistent id then `Root (ModuleName.of_ident id) + if Ident.is_global_or_predef id then `Root (ModuleName.of_ident id) else try find_module env id with Not_found -> assert false diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 73b4bb73bf..921834d5a8 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -1,7 +1,7 @@ #if OCAML_VERSION >= (4, 14, 0) let rec is_persistent : Path.t -> bool = function - | Path.Pident id -> Ident.persistent id + | Path.Pident id -> Ident.is_global_or_predef id | Path.Pdot(p, _) -> is_persistent p | Path.Papply(p, _) -> is_persistent p #if OCAML_VERSION >= (5,1,0) From ce434a66ab3fd22be78ec59d8182d3f4927b41cb Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 07:28:55 -0400 Subject: [PATCH 07/25] Support OxCaml modes in loader (#6) --- src/loader/cmi.ml | 22 ++++++++++++---------- src/loader/cmt.ml | 10 +++++++--- src/loader/cmti.ml | 8 +++++--- src/loader/ident_env.cppo.ml | 17 +++++++++++------ src/loader/typedtree_traverse.ml | 10 ++++++---- src/odoc/extract_code.cppo.ml | 2 +- 6 files changed, 42 insertions(+), 27 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index db6791aafb..e559c95a9b 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -296,6 +296,7 @@ let mark_type ty = | Tsubst (ty,_) -> loop visited ty #endif | Tlink _ -> assert false + | Tof_kind _ -> () in loop [] ty @@ -359,7 +360,7 @@ let mark_constructor_args = List.iter mark_type #else function - | Cstr_tuple args -> List.iter mark_type args + | Cstr_tuple args -> List.iter (fun carg -> mark_type carg.ca_type) args | Cstr_record lds -> List.iter (fun ld -> mark_type ld.ld_type) lds #endif @@ -370,7 +371,7 @@ let mark_type_kind = function | Type_abstract -> () #endif #if OCAML_VERSION >= (4,13,0) - | Type_variant (cds,_) -> + | Type_variant (cds,_,_) -> #else | Type_variant cds -> #endif @@ -379,7 +380,7 @@ let mark_type_kind = function mark_constructor_args cd.cd_args; opt_iter mark_type cd.cd_res) cds - | Type_record(lds, _) -> + | Type_record(lds, _, _) -> List.iter (fun ld -> mark_type ld.ld_type) lds | Type_open -> () @@ -462,7 +463,7 @@ let rec read_type_expr env typ = let name = name_of_type typ in if name = "_" then Any else Var name - | Tarrow(lbl, arg, res, _) -> + | Tarrow((lbl,_,_), arg, res, _) -> let lbl = read_label lbl in let lbl,arg = match lbl with @@ -533,6 +534,7 @@ let rec read_type_expr env typ = | Tsubst (typ,_) -> read_type_expr env typ #endif | Tlink _ -> assert false + | Tof_kind _ -> assert false in match alias with | None -> typ @@ -676,7 +678,7 @@ let read_label_declaration env parent ld = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag (parent :> Identifier.LabelParent.t) ld.ld_attributes in - let mutable_ = (ld.ld_mutable = Mutable) in + let mutable_ = is_mutable ld.ld_mutable in let type_ = read_type_expr env ld.ld_type in {id; doc; mutable_; type_} @@ -689,7 +691,7 @@ let read_constructor_declaration_arguments env parent arg = #else let open TypeDecl.Constructor in match arg with - | Cstr_tuple args -> Tuple (List.map (read_type_expr env) args) + | Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg.ca_type) args) | Cstr_record lds -> Record (List.map (read_label_declaration env parent) lds) #endif @@ -715,7 +717,7 @@ let read_type_kind env parent = #endif None #if OCAML_VERSION >= (4,13,0) - | Type_variant (cstrs,_) -> + | Type_variant (cstrs,_,_) -> #else | Type_variant cstrs -> #endif @@ -723,7 +725,7 @@ let read_type_kind env parent = List.map (read_constructor_declaration env parent) cstrs in Some (Variant cstrs) - | Type_record(lbls, _) -> + | Type_record(lbls, _, _) -> let lbls = List.map (read_label_declaration env (parent :> Identifier.FieldParent.t)) @@ -799,7 +801,7 @@ let read_type_declaration env parent id decl = | Type_record _ -> decl.type_private = Private #if OCAML_VERSION >= (4,13,0) - | Type_variant (tll,_) -> + | Type_variant (tll,_,_) -> #else | Type_variant tll -> #endif @@ -875,7 +877,7 @@ let read_instance_variable env parent (name, mutable_, virtual_, typ) = let open InstanceVariable in let id = Identifier.Mk.instance_variable(parent, Odoc_model.Names.InstanceVariableName.make_std name) in let doc = Doc_attr.empty env.warnings_tag in - let mutable_ = (mutable_ = Mutable) in + let mutable_ = (mutable_ = Asttypes.Mutable) in let virtual_ = (virtual_ = Virtual) in let type_ = read_type_expr env typ in ClassSignature.InstanceVariable {id; doc; mutable_; virtual_; type_} diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index f78c73b97c..74793def65 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -40,9 +40,9 @@ let rec read_pattern env parent doc pat = match pat.pat_desc with | Tpat_any -> [] #if OCAML_VERSION < (5,2,0) - | Tpat_var(id, _) -> + | Tpat_var(id, _, _, _) -> #else - | Tpat_var(id,_,_uid) -> + | Tpat_var(id,_,_uid, _) -> #endif let open Value in let id = Env.find_value_identifier env.ident_env id in @@ -52,6 +52,8 @@ let rec read_pattern env parent doc pat = [Value {id; source_loc; doc; type_; value}] #if OCAML_VERSION < (5,2, 0) | Tpat_alias(pat, id, _) -> +#elif OCAML_VERSION = (5,2, 0) + | Tpat_alias(pat, id, _,_, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, _,_) -> #else @@ -83,7 +85,9 @@ let rec read_pattern env parent doc pat = (List.map (fun (_, _, pat) -> read_pattern env parent doc pat) pats) -#if OCAML_VERSION < (5, 4, 0) +#if OCAML_VERSION = (5, 2, 0) + | Tpat_array (_, pats) -> +#elif OCAML_VERSION < (5, 4, 0) | Tpat_array pats -> #else | Tpat_array (_, pats) -> diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 67281a5d91..a2cabbaa0b 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -164,6 +164,7 @@ let rec read_core_type env container ctyp = (* TODO: adjust model *) read_core_type env container t #endif + | Ttyp_of_kind _ -> assert false let read_value_description env parent vd = let open Signature in @@ -220,7 +221,7 @@ let read_label_declaration env parent label_parent ld = let name = Ident.name ld.ld_id in let id = Identifier.Mk.field(parent, FieldName.make_std name) in let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in - let mutable_ = (ld.ld_mutable = Mutable) in + let mutable_ = Types.is_mutable ld.ld_mutable in let type_ = read_core_type env label_parent ld.ld_type in {id; doc; mutable_; type_} @@ -231,7 +232,8 @@ let read_constructor_declaration_arguments env parent label_parent arg = Tuple (List.map (read_core_type env label_parent) arg) #else match arg with - | Cstr_tuple args -> Tuple (List.map (read_core_type env label_parent) args) + | Cstr_tuple args -> + Tuple (List.map (fun arg -> read_core_type env label_parent arg.ca_type) args) | Cstr_record lds -> Record (List.map (read_label_declaration env parent label_parent) lds) #endif @@ -724,7 +726,7 @@ and read_signature_item env parent item = [ Open (read_open env parent o) ] - | Tsig_include incl -> + | Tsig_include (incl, _) -> read_include env parent incl | Tsig_class cls -> read_class_descriptions env parent cls diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 09cb3c4af0..47c45df63a 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -118,11 +118,11 @@ and extract_signature_type_items_extract vis ~hidden item rest = #else | Types.Type_abstract _ -> [] #endif - | Type_record (_, _) -> [] + | Type_record (_, _, _) -> [] #if OCAML_VERSION < (4,13,0) | Type_variant cstrs -> #else - | Type_variant (cstrs, _) -> + | Type_variant (cstrs, _, _) -> #endif List.map (fun c -> `Constructor (c.Types.cd_id, id, Some c.cd_loc)) cstrs | Type_open -> [] in @@ -249,7 +249,7 @@ let rec extract_signature_tree_items : bool -> Typedtree.signature_item list -> [`Value (val_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest | { sig_desc = Tsig_modtype mtd; sig_loc; _} :: rest -> [`ModuleType (mtd.mtd_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest - | {sig_desc = Tsig_include incl; _ } :: rest -> + | {sig_desc = Tsig_include (incl, _); _ } :: rest -> [`Include (extract_signature_type_items Exported (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest | {sig_desc = Tsig_attribute attr; _ } :: rest -> let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in @@ -301,13 +301,15 @@ let rec read_pattern hide_item pat = let open Typedtree in match pat.pat_desc with #if OCAML_VERSION < (5,2,0) - | Tpat_var(id, loc) -> + | Tpat_var(id, loc, _, _) -> #else - | Tpat_var(id, loc, _) -> + | Tpat_var(id, loc, _, _) -> #endif [`Value(id, hide_item, Some loc.loc)] #if OCAML_VERSION < (5,2,0) | Tpat_alias(pat, id, loc) -> +#elif OCAML_VERSION = (5,2,0) + | Tpat_alias(pat, id, loc, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, loc, _) -> #else @@ -321,7 +323,10 @@ let rec read_pattern hide_item pat = #else | Tpat_construct(_, _, pats, _) #endif -#if OCAML_VERSION < (5,4,0) +#if OCAML_VERSION = (5,2,0) + | Tpat_array (_, pats) -> + List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats) +#elif OCAML_VERSION < (5,4,0) | Tpat_array pats -> List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #else diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 8bd0375160..ec9b8bf9ec 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -13,7 +13,7 @@ module Analysis = struct if exp_loc.loc_ghost then () else match expr.exp_desc with - | Texp_ident (p, _, _) -> poses := (Value p, exp_loc) :: !poses + | Texp_ident (p, _, _, _, _) -> poses := (Value p, exp_loc) :: !poses | _ -> () let pat env (type a) poses : a Typedtree.general_pattern -> unit = function @@ -26,19 +26,21 @@ module Analysis = struct let () = match pat_desc with #if OCAML_VERSION >= (5, 2, 0) - | Tpat_var (id, loc, _uid) -> ( + | Tpat_var (id, loc, _uid, _) -> ( #else - | Tpat_var (id, loc) -> ( + | Tpat_var (id, loc, _, _) -> ( #endif match maybe_localvalue id loc.loc with | Some x -> poses := x :: !poses | None -> ()) #if OCAML_VERSION >= (5, 4, 0) | Tpat_alias (_, id, loc, _uid, _ty) -> ( +#elif OCAML_VERSION = (5, 2, 0) + | Tpat_alias (_, id, loc, _uid, _, _) -> ( #elif OCAML_VERSION >= (5, 2, 0) | Tpat_alias (_, id, loc, _uid) -> ( #else - | Tpat_alias (_, id, loc) -> ( + | Tpat_alias (_, id, loc, _, _) -> ( #endif match maybe_localvalue id loc.loc with | Some x -> poses := x :: !poses diff --git a/src/odoc/extract_code.cppo.ml b/src/odoc/extract_code.cppo.ml index 6d98c2ce63..2ceb076a89 100644 --- a/src/odoc/extract_code.cppo.ml +++ b/src/odoc/extract_code.cppo.ml @@ -88,7 +88,7 @@ let iterator line_directives oc names = let signature_item sub sig_ = match sig_.Typedtree.sig_desc with | Tsig_attribute attr -> attribute sub attr - | Tsig_include incl -> attributes sub incl.incl_attributes + | Tsig_include (incl, _) -> attributes sub incl.incl_attributes | Tsig_open o -> attributes sub o.open_attributes | _ -> default_iterator.signature_item sub sig_ in From 1fe6ff343741fbce40e55ce6228c0c2ec9fb8579 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 09:03:36 -0400 Subject: [PATCH 08/25] Support OxCaml layouts in loader (#7) --- src/loader/cmi.ml | 16 +++++++++++----- src/loader/cmti.ml | 33 ++++++++++++++++++++++++--------- 2 files changed, 35 insertions(+), 14 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index e559c95a9b..71ae065aa7 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -161,7 +161,7 @@ let name_of_type_repr (ty : Compat.repr_type_node) = with Not_found -> let base = match ty.desc with - | Tvar (Some name) | Tunivar (Some name) -> name + | Tvar { name = Some name; _ } | Tunivar { name = Some name; _ } -> name | _ -> next_name () in let name = fresh_name base in @@ -191,7 +191,7 @@ let add_alias_proxy px = if not (List.memq px !aliased) then begin aliased := px :: !aliased; match px.desc with - | Tvar name | Tunivar name -> reserve_name name + | Tvar { name; _ } | Tunivar { name; _ } -> reserve_name name | _ -> () end @@ -234,7 +234,7 @@ let mark_type ty = if List.memq px visited && aliasable ty then add_alias_proxy px else let visited = px :: visited in match Compat.get_desc ty with - | Tvar name -> reserve_name name + | Tvar { name; _ } -> reserve_name name | Tarrow(_, ty1, ty2, _) -> loop visited ty1; loop visited ty2 @@ -279,7 +279,11 @@ let mark_type ty = | Tpoly (ty, tyl) -> List.iter (fun t -> add_alias t) tyl; loop visited ty +#if OCAML_VERSION = (5,2,0) + | Tunivar { name; _ } -> reserve_name name +#else | Tunivar name -> reserve_name name +#endif #if OCAML_VERSION>=(5,4,0) | Tpackage p -> List.iter (fun (_,x) -> loop visited x) p.pack_cstrs @@ -324,7 +328,8 @@ let tvar_none ty = ty.desc <- Tvar None #elif OCAML_VERSION < (4,14,0) let tvar_none ty = Types.Private_type_expr.set_desc ty (Tvar None) #else -let tvar_none ty = Types.Transient_expr.(set_desc (coerce ty) (Tvar None)) +let tvar_none ty jkind = + Types.Transient_expr.(set_desc (coerce ty) (Tvar { name = None; jkind })) #endif let wrap_constrained_params tyl = @@ -347,7 +352,8 @@ let prepare_type_parameters params manifest = let vars = Ctype.free_variables ty in List.iter (fun ty -> match Compat.get_desc ty with - | Tvar (Some "_") -> if List.memq ty vars then tvar_none ty + | Tvar { name = Some "_"; jkind } -> + if List.memq ty vars then tvar_none ty jkind | _ -> ()) params | None -> () diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index a2cabbaa0b..f6350db9aa 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -42,8 +42,10 @@ let read_label = Cmi.read_label let rec read_core_type env container ctyp = let open TypeExpr in match ctyp.ctyp_desc with - | Ttyp_any -> Any - | Ttyp_var s -> Var s + (* TODO: presumably we want the layout in these first two cases, + eventually *) + | Ttyp_var (None, _layout) -> Any + | Ttyp_var (Some s, _layout) -> Var s | Ttyp_arrow(lbl, arg, res) -> let lbl = read_label lbl in #if OCAML_VERSION < (4,3,0) @@ -105,13 +107,18 @@ let rec read_core_type env container ctyp = let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_core_type env container) params in Class(p, params) - | Ttyp_alias(typ, var) -> + | Ttyp_alias(typ, var, _layout) -> + (* TODO: presumably we want the layout, eventually *) let typ = read_core_type env container typ in + begin match var with + | None -> typ + | Some var -> #if OCAML_VERSION >= (5,2,0) - Alias(typ, var.txt) + Alias(typ, var.txt) #else - Alias(typ, var) + Alias(typ, var) #endif + end | Ttyp_variant(fields, closed, present) -> let open TypeExpr.Polymorphic_variant in let elements = @@ -142,7 +149,13 @@ let rec read_core_type env container ctyp = in Polymorphic_variant {kind; elements} | Ttyp_poly([], typ) -> read_core_type env container typ +#if OCAML_VERSION = (5,2,0) + | Ttyp_poly(vars, typ) -> + (* TODO: presumably want the layouts, eventually *) + Poly(List.map fst vars, read_core_type env container typ) +#else | Ttyp_poly(vars, typ) -> Poly(vars, read_core_type env container typ) +#endif #if OCAML_VERSION >= (5,4,0) | Ttyp_package {tpt_path = pack_path; tpt_cstrs=pack_fields; _} -> #else @@ -185,9 +198,10 @@ let read_value_description env parent vd = let read_type_parameter (ctyp, var_and_injectivity) = let open TypeDecl in let desc = + (* TODO: presumably we want the layouts below, eventually *) match ctyp.ctyp_desc with - | Ttyp_any -> Any - | Ttyp_var s -> Var s + | Ttyp_var (None, _layout) -> Any + | Ttyp_var (Some s, _layout) -> Var s | _ -> assert false in let variance, injectivity = @@ -402,8 +416,9 @@ let rec read_class_type_field env parent ctf = | Some doc -> Some (Comment doc) and read_self_type env container typ = - if typ.ctyp_desc = Ttyp_any then None - else Some (read_core_type env container typ) + match typ.ctyp_desc with + | Ttyp_var (None, _) -> None + | _ -> Some (read_core_type env container typ) and read_class_signature env parent label_parent cltyp = let open ClassType in From 3d3a867249631f459b0c7d2ed202f4294490b73b Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 09:07:39 -0400 Subject: [PATCH 09/25] Support OxCaml module type strengthening operator (#8) --- src/document/generator.ml | 23 +++++++++++++++++++---- src/document/targets.ml | 3 ++- src/index/skeleton.ml | 2 ++ src/loader/cmi.ml | 11 +++++++++++ src/loader/cmti.ml | 8 ++++++++ src/loader/implementation.ml | 1 + src/model/compat.cppo.ml | 11 +++++++++++ src/model/lang.ml | 14 +++++++++++++- src/model_desc/lang_desc.ml | 20 ++++++++++++++++++-- src/xref2/compile.ml | 8 ++++++++ src/xref2/component.ml | 28 ++++++++++++++++++++++++++++ src/xref2/component.mli | 9 +++++++++ src/xref2/lang_of.ml | 12 ++++++++++++ src/xref2/link.ml | 11 +++++++++++ src/xref2/subst.ml | 15 ++++++++++++++- src/xref2/tools.ml | 9 +++++++++ test/odoc_print/odoc_print.ml | 2 ++ 17 files changed, 178 insertions(+), 9 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 7a99172f09..bcc3d08edb 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1417,11 +1417,13 @@ module Make (Syntax : SYNTAX) = struct match t with | Path { p_expansion = None; _ } | TypeOf { t_expansion = None; _ } - | With { w_expansion = None; _ } -> + | With { w_expansion = None; _ } + | Strengthen { s_expansion = None; _ } -> None | Path { p_expansion = Some e; _ } | TypeOf { t_expansion = Some e; _ } - | With { w_expansion = Some e; _ } -> + | With { w_expansion = Some e; _ } + | Strengthen { s_expansion = Some e; _ } -> Some e | Signature sg -> Some (Signature sg) | Functor (f_parameter, e) -> ( @@ -1560,6 +1562,8 @@ module Make (Syntax : SYNTAX) = struct | TypeOf (ModPath m, _) | TypeOf (StructInclude m, _) -> Paths.Path.(is_hidden (m :> t)) | Signature _ -> false + | Strengthen (expr, p, _) -> + umty_hidden expr || Paths.Path.(is_hidden (p :> t)) and mty_hidden : Odoc_model.Lang.ModuleType.expr -> bool = function | Path { p_path = mty_path; _ } -> Paths.Path.(is_hidden (mty_path :> t)) @@ -1576,6 +1580,10 @@ module Make (Syntax : SYNTAX) = struct ~f:(fun x -> O.span (substitution x)) subs + and mty_strengthen expr path = + umty expr ++ O.sp ++ O.keyword "with" ++ O.txt " " + ++ Link.from_path (path :> Paths.Path.t) + and mty_typeof t_desc = match t_desc with | Odoc_model.Lang.ModuleType.ModPath m -> @@ -1595,6 +1603,7 @@ module Make (Syntax : SYNTAX) = struct | Signature _ -> true | With (_, expr) -> is_elidable_with_u expr | TypeOf _ -> false + | Strengthen (expr,_,_) -> is_elidable_with_u expr and umty : Odoc_model.Lang.ModuleType.U.expr -> text = fun m -> @@ -1606,6 +1615,9 @@ module Make (Syntax : SYNTAX) = struct Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag | With (subs, expr) -> mty_with subs expr | TypeOf (t_desc, _) -> mty_typeof t_desc + | Strengthen (expr, _, _) when is_elidable_with_u expr -> + Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag + | Strengthen (expr, p, _) -> mty_strengthen expr (p :> Paths.Path.t) and mty : Odoc_model.Lang.ModuleType.expr -> text = fun m -> @@ -1644,12 +1656,15 @@ module Make (Syntax : SYNTAX) = struct | TypeOf { t_desc; _ } -> mty_typeof t_desc | Signature _ -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag - + | Strengthen { s_expr; _ } when is_elidable_with_u s_expr -> + Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag + | Strengthen { s_expr; s_path; _ } -> + O.box_hv @@ mty_strengthen s_expr (s_path :> Paths.Path.t) and mty_in_decl : Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text = fun base -> function - | (Path _ | Signature _ | With _ | TypeOf _) as m -> + | (Path _ | Signature _ | With _ | TypeOf _ | Strengthen _) as m -> O.txt Syntax.Type.annotation_separator ++ O.cut ++ mty m | Functor _ as m when not Syntax.Mod.functor_contraction -> O.txt Syntax.Type.annotation_separator ++ O.cut ++ mty m diff --git a/src/document/targets.ml b/src/document/targets.ml index 64d261d7ca..70c4ce7704 100644 --- a/src/document/targets.ml +++ b/src/document/targets.ml @@ -49,7 +49,8 @@ and module_type_expr (t : Odoc_model.Lang.ModuleType.expr) = sub @ module_type_expr e | Path { p_expansion = e_opt; _ } | With { w_expansion = e_opt; _ } - | TypeOf { t_expansion = e_opt; _ } -> + | TypeOf { t_expansion = e_opt; _ } + | Strengthen { s_expansion = e_opt; _ } -> opt_expansion e_opt and module_ (t : Odoc_model.Lang.Module.t) = diff --git a/src/index/skeleton.ml b/src/index/skeleton.ml index f7e693dfc2..67cf5cd045 100644 --- a/src/index/skeleton.ml +++ b/src/index/skeleton.ml @@ -282,9 +282,11 @@ and module_type_expr id mte = | With { w_expansion = Some sg; _ } -> simple_expansion id sg | TypeOf { t_expansion = Some sg; _ } -> simple_expansion id sg | Path { p_expansion = Some sg; _ } -> simple_expansion id sg + | Strengthen { s_expansion = Some sg; _ } -> simple_expansion id sg | Path { p_expansion = None; _ } -> [] | With { w_expansion = None; _ } -> [] | TypeOf { t_expansion = None; _ } -> [] + | Strengthen { s_expansion = None; _ } -> [] and class_signature id ct_expr = let items = filter_class_signature ct_expr.items in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 71ae065aa7..556273f533 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -1030,6 +1030,17 @@ let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = let t_original_path = Env.Path.read_module env.ident_env p in let t_desc = ModPath t_original_path in TypeOf { t_desc; t_expansion = None; t_original_path } + | Mty_strengthen (mty, p, a) -> + let mty = read_module_type env parent mty in + let s_path = Env.Path.read_module env.ident_env p in + let s_aliasable = match a with + | Aliasable -> true + | Not_aliasable -> false + in + match Odoc_model.Lang.umty_of_mty mty with + | Some s_expr -> + Strengthen {s_expr; s_path; s_aliasable; s_expansion = None} + | None -> failwith "invalid Mty_strengthen" and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_declaration) = let open ModuleType in diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index f6350db9aa..4d6c48c298 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -614,6 +614,14 @@ and read_module_type env parent label_parent mty = in decl | Tmty_alias _ -> assert false + | Tmty_strengthen (mty, path, _) -> + let mty = read_module_type env parent label_parent mty in + let s_path = Env.Path.read_module env.ident_env path in + match Odoc_model.Lang.umty_of_mty mty with + | Some s_expr -> + (* We always strengthen with aliases *) + Strengthen {s_expr; s_path; s_aliasable = true; s_expansion = None} + | None -> failwith "invalid Tmty_strengthen" (** Like [read_module_type] but handle the canonical tag in the top-comment. If [canonical] is [Some _], no tag is expected in the top-comment. *) diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 921834d5a8..bfa2c16ed3 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -70,6 +70,7 @@ module Env = struct | Tmty_signature sg -> signature env (parent : Identifier.Signature.t) sg | Tmty_with (mty, _) -> module_type env parent mty | Tmty_functor (_, t) -> module_type env parent t + | Tmty_strengthen (t, _, _) -> module_type env parent t | Tmty_ident _ | Tmty_alias _ | Tmty_typeof _ -> () and module_bindings env parent mbs = List.iter (module_binding env parent) mbs diff --git a/src/model/compat.cppo.ml b/src/model/compat.cppo.ml index 106a966cdf..b73518cbff 100644 --- a/src/model/compat.cppo.ml +++ b/src/model/compat.cppo.ml @@ -28,11 +28,16 @@ type visibility = | Exported | Hidden +module Aliasability = struct + type t = Not_aliasable | Aliasable +end + type module_type = Mty_ident of Path.t | Mty_signature of signature | Mty_functor of functor_parameter * module_type | Mty_alias of Path.t + | Mty_strengthen of module_type * Path.t * Aliasability.t and functor_parameter = | Unit @@ -88,11 +93,17 @@ and visibility : Types.visibility -> visibility = function | Types.Hidden -> Hidden | Types.Exported -> Exported +and aliasability : Types.Aliasability.t -> Aliasability.t = function + | Types.Aliasability.Not_aliasable -> Aliasability.Not_aliasable + | Types.Aliasability.Aliasable -> Aliasability.Aliasable + and module_type : Types.module_type -> module_type = function | Types.Mty_ident p -> Mty_ident p | Types.Mty_signature s -> Mty_signature (signature s) | Types.Mty_functor (a, b) -> Mty_functor(functor_parameter a, module_type b) | Types.Mty_alias p -> Mty_alias p + | Types.Mty_strengthen (mty,p,a) -> + Mty_strengthen (module_type mty, p, aliasability a) and functor_parameter : Types.functor_parameter -> functor_parameter = function | Types.Unit -> Unit diff --git a/src/model/lang.ml b/src/model/lang.ml index 429067ead7..7ec1d7e3bb 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -83,6 +83,7 @@ and ModuleType : sig | Signature of Signature.t | With of substitution list * expr | TypeOf of type_of_desc * Path.Module.t + | Strengthen of expr * Path.Module.t * bool end type path_t = { @@ -96,12 +97,20 @@ and ModuleType : sig w_expr : U.expr; } + type strengthen_t = { + s_expansion : simple_expansion option; + s_expr : U.expr; + s_path : Path.Module.t; + s_aliasable : bool + } + type expr = | Path of path_t | Signature of Signature.t | Functor of FunctorParameter.t * expr | With of with_t | TypeOf of typeof_t + | Strengthen of strengthen_t type t = { id : Identifier.ModuleType.t; @@ -552,6 +561,8 @@ let umty_of_mty : ModuleType.expr -> ModuleType.U.expr option = function | TypeOf { t_desc; t_original_path; _ } -> Some (TypeOf (t_desc, t_original_path)) | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) + | Strengthen { s_expr; s_path; s_aliasable; _ } -> + Some (Strengthen (s_expr, s_path, s_aliasable)) (** Query the top-comment of a signature. This is [s.doc] most of the time with an exception for signature starting with an inline includes. *) @@ -560,7 +571,8 @@ let extract_signature_doc (s : Signature.t) = | ModuleType.U.Path p -> Path.is_hidden (p :> Path.t) | Signature _ -> true (* Hidden in some sense, we certainly want its top comment *) - | With (_, e) -> uexpr_considered_hidden e + | With (_, e) + | Strengthen (e, _, _) -> uexpr_considered_hidden e | TypeOf (ModPath p, _) | TypeOf (StructInclude p, _) -> Path.is_hidden (p :> Path.t) in diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index da0ebad61e..c0bd871dc5 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -145,6 +145,16 @@ and moduletype_typeof_t = F ("t_expansion", (fun t -> t.t_expansion), Option simple_expansion); ] +and moduletype_strengthen_t : Lang.ModuleType.strengthen_t t = + let open Lang.ModuleType in + Record + [ + F ("s_expansion", (fun t -> t.s_expansion), Option simple_expansion); + F ("s_expr", (fun t -> t.s_expr), moduletype_u_expr); + F ("s_path", (fun t -> (t.s_path :> Paths.Path.t)), path); + F ("s_aliasable", (fun t -> t.s_aliasable), bool); + ] + and moduletype_expr = let open Lang.ModuleType in Variant @@ -154,7 +164,8 @@ and moduletype_expr = | Functor (x1, x2) -> C ("Functor", (x1, x2), Pair (functorparameter_t, moduletype_expr)) | With t -> C ("With", t, moduletype_with_t) - | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t)) + | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t) + | Strengthen x -> C ("Strengthen", x, moduletype_strengthen_t)) and moduletype_u_expr = let open Lang.ModuleType.U in @@ -171,7 +182,12 @@ and moduletype_u_expr = C ( "TypeOf", (t, (o :> Paths.Path.t)), - Pair (moduletype_type_of_desc, path) )) + Pair (moduletype_type_of_desc, path) ) + | Strengthen (e, x, a) -> + C + ( "Strengthen", + (e, (x :> Paths.Path.t), a), + Triple (moduletype_u_expr, path, bool) )) and moduletype_t = let open Lang.ModuleType in diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 0ccc1a7529..cde6e8c49b 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -629,6 +629,7 @@ and module_type_map_subs env id cexpr subs = -> Some (`Module p) | TypeOf _ -> None + | Strengthen (e, _, _) -> find_parent e in match find_parent cexpr with | None -> None @@ -673,6 +674,8 @@ and u_module_type_expr : | StructInclude p -> StructInclude (module_path env p) in TypeOf (t_desc, t_original_path) + | Strengthen (expr, path, aliasable) -> + Strengthen (inner expr, module_path env path, aliasable) in inner expr @@ -739,6 +742,11 @@ and module_type_expr : | StructInclude p -> StructInclude (module_path env p) in TypeOf { t_desc; t_original_path; t_expansion } + | Strengthen { s_expr; s_path; s_aliasable; s_expansion } as e -> + let s_expansion = get_expansion s_expansion e in + let s_expr = u_module_type_expr env id s_expr in + let s_path = module_path env s_path in + Strengthen { s_expr; s_path; s_aliasable; s_expansion } and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t = fun env t -> diff --git a/src/xref2/component.ml b/src/xref2/component.ml index b2068e8030..7dbc1b7487 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -199,6 +199,7 @@ and ModuleType : sig | Signature of Signature.t | With of substitution list * expr | TypeOf of type_of_desc * Cpath.module_ + | Strengthen of expr * Cpath.module_ * bool end type path_t = { @@ -212,12 +213,20 @@ and ModuleType : sig w_expr : U.expr; } + type strengthen_t = { + s_expansion : simple_expansion option; + s_expr : U.expr; + s_path : Cpath.module_; + s_aliasable : bool + } + type expr = | Path of path_t | Signature of Signature.t | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t + | Strengthen of strengthen_t type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; @@ -943,6 +952,8 @@ module Fmt = struct Format.fprintf ppf "%a with [%a]" (u_module_type_expr c) e (substitution_list c) subs | TypeOf (t_desc, _) -> module_type_type_of_desc c ppf t_desc + | Strengthen (e, p, _) -> + Format.fprintf ppf "%a with %a" (u_module_type_expr c) e (module_path c) p and module_type_expr c ppf mt = let open ModuleType in @@ -961,6 +972,9 @@ module Fmt = struct | TypeOf { t_desc = StructInclude p; _ } -> Format.fprintf ppf "module type of struct include %a end" (module_path c) p + | Strengthen { s_expr; s_path; _ } -> + Format.fprintf ppf "%a with %a" (u_module_type_expr c) s_expr + (module_path c) s_path and module_type_expansion c ppf mt = let open ModuleType in @@ -2409,6 +2423,10 @@ module Of_Lang = struct (* see comment in module_type_expr below *) let t_original_path = module_path (empty ()) t_original_path in TypeOf (t_desc, t_original_path) + | Strengthen (e, p, a) -> + let e = u_module_type_expr ident_map e in + let p = module_path ident_map p in + Strengthen (e, p, a) and module_type_expr ident_map m = let open Odoc_model in @@ -2469,6 +2487,16 @@ module Of_Lang = struct _create_ a `TypeOf` expression as part of fragmap *) let t_original_path = module_path (empty ()) t_original_path in ModuleType.(TypeOf { t_desc; t_original_path; t_expansion }) + | Lang.ModuleType.Strengthen s -> + let s' = + ModuleType. + { s_expr = u_module_type_expr ident_map s.s_expr; + s_path = module_path ident_map s.s_path; + s_aliasable = s.s_aliasable; + s_expansion = option simple_expansion ident_map s.s_expansion + } + in + ModuleType.Strengthen s' and module_type ident_map m = let expr = diff --git a/src/xref2/component.mli b/src/xref2/component.mli index cb0a60eb07..0719e2f1aa 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -190,6 +190,7 @@ and ModuleType : sig | Signature of Signature.t | With of substitution list * expr | TypeOf of type_of_desc * Cpath.module_ + | Strengthen of expr * Cpath.module_ * bool end type path_t = { @@ -203,12 +204,20 @@ and ModuleType : sig w_expr : U.expr; } + type strengthen_t = { + s_expansion : simple_expansion option; + s_expr : U.expr; + s_path : Cpath.module_; + s_aliasable : bool + } + type expr = | Path of path_t | Signature of Signature.t | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t + | Strengthen of strengthen_t type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 2401576c00..2a19af0cf6 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -799,6 +799,10 @@ and u_module_type_expr map identifier = function TypeOf (ModPath (Path.module_ map p), Path.module_ map original_path) | TypeOf (StructInclude p, original_path) -> TypeOf (StructInclude (Path.module_ map p), Path.module_ map original_path) + | Strengthen (expr, path, aliasable) -> + let expr = u_module_type_expr map identifier expr in + let path = Path.module_ map path in + Strengthen (expr, path, aliasable) and module_type_expr map identifier = function | Component.ModuleType.Path { p_path; p_expansion } -> @@ -849,6 +853,14 @@ and module_type_expr map identifier = function t_original_path = Path.module_ map t_original_path; t_expansion = Opt.map (simple_expansion map identifier) t_expansion; } + | Strengthen { s_expr; s_path; s_aliasable; s_expansion } -> + Strengthen + { + s_expr = u_module_type_expr map identifier s_expr; + s_path = Path.module_ map s_path; + s_aliasable; + s_expansion = Opt.map (simple_expansion map identifier) s_expansion + } and module_type : maps -> diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 4e8c5e099c..08431dea7e 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -893,6 +893,9 @@ and u_module_type_expr : TypeOf (StructInclude (module_path env p), original_path) | TypeOf (ModPath p, original_path) -> TypeOf (ModPath (module_path env p), original_path) + | Strengthen (expr, path, aliasable) -> + let expr = u_module_type_expr env id expr in + Strengthen (expr, module_path env path, aliasable) and module_type_expr : Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr = @@ -957,6 +960,14 @@ and module_type_expr : t_expansion = do_expn t_expansion None; t_original_path; } + | Strengthen { s_expr; s_path; s_aliasable; s_expansion } -> + Strengthen + { + s_expr = u_module_type_expr env id s_expr; + s_path = module_path env s_path; + s_aliasable; + s_expansion = do_expn s_expansion None; + } and type_decl_representation : Env.t -> diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 56658e4e3b..7335b529d1 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -613,13 +613,18 @@ and u_module_type_expr s t = | With w -> With (w.w_substitutions, w.w_expr) | Functor _ -> (* non functor cannot be substituted away to a functor *) - assert false)) + assert false + | Strengthen s -> Strengthen (s.s_expr, s.s_path, s.s_aliasable))) | Signature sg -> Signature (signature s sg) | With (subs, e) -> With (List.map (with_module_type_substitution s) subs, u_module_type_expr s e) | TypeOf (t_desc, t_original_path) -> TypeOf (module_type_type_of_desc s t_desc, t_original_path) + | Strengthen (expr, path, aliasable) -> + let expr = u_module_type_expr s expr in + let path = module_path s path in + Strengthen (expr, path, aliasable) and module_type_expr s t = let open Component.ModuleType in @@ -647,6 +652,14 @@ and module_type_expr s t = t_desc = module_type_type_of_desc s t.t_desc; t_expansion = option_ simple_expansion s t.t_expansion; } + | Strengthen { s_expr; s_path; s_aliasable; s_expansion } -> + Strengthen + { + s_expr = u_module_type_expr s s_expr; + s_path = module_path s s_path; + s_aliasable; + s_expansion = option_ simple_expansion s s_expansion + } and with_module_type_substitution s sub = let open Component.ModuleType in diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index fbd85602b6..f7aa4ea604 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1631,6 +1631,9 @@ and signature_of_u_module_type_expr : handle_signature_with_subs env sg subs | TypeOf (desc, original_path) -> signature_of_module_type_of env desc ~original_path >>= assert_not_functor + | Strengthen (expr, path, _aliasable) -> + signature_of_u_module_type_expr env expr >>= fun sg -> + Ok (Strengthen.signature path sg) and expansion_of_simple_expansion : Component.ModuleType.simple_expansion -> expansion = @@ -1673,6 +1676,10 @@ and expansion_of_module_type_expr : | StructInclude p -> (p, true) in expansion_of_module_path env ~strengthen p + | Component.ModuleType.Strengthen { s_expr; s_path; _ } -> + signature_of_u_module_type_expr env s_expr >>= fun sg -> + let sg = Strengthen.signature s_path sg in + Ok (Signature sg) and expansion_of_module_type : Env.t -> @@ -1759,6 +1766,8 @@ and umty_of_mty : Component.ModuleType.expr -> Component.ModuleType.U.expr = | TypeOf { t_desc; t_original_path; _ } -> TypeOf (t_desc, t_original_path) | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) | Functor _ -> assert false + | Strengthen { s_expr; s_path; s_aliasable; _ } -> + Strengthen (s_expr, s_path, s_aliasable) and fragmap : Env.t -> diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index 265c365203..625a008e26 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -37,6 +37,8 @@ and signature_of_module_type_expr = function | TypeOf _ -> None | With { w_expansion = Some e; _ } -> Some (signature_of_simple_expansion e) | With _ -> None + | Strengthen { s_expansion = Some e; _ } -> Some (signature_of_simple_expansion e) + | Strengthen _ -> None and signature_of_module : Odoc_model.Lang.Module.t -> Odoc_model.Lang.Signature.t option = From e795f93097f5713d8d39fea8054eb781d35de367 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 09:11:48 -0400 Subject: [PATCH 10/25] Support OxCaml `iarray` syntax in loader (#9) --- src/loader/cmt.ml | 2 +- src/loader/ident_env.cppo.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 74793def65..5e3ce473f1 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -86,7 +86,7 @@ let rec read_pattern env parent doc pat = (fun (_, _, pat) -> read_pattern env parent doc pat) pats) #if OCAML_VERSION = (5, 2, 0) - | Tpat_array (_, pats) -> + | Tpat_array (_, _, pats) -> #elif OCAML_VERSION < (5, 4, 0) | Tpat_array pats -> #else diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 47c45df63a..8f5406d77c 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -324,7 +324,7 @@ let rec read_pattern hide_item pat = | Tpat_construct(_, _, pats, _) #endif #if OCAML_VERSION = (5,2,0) - | Tpat_array (_, pats) -> + | Tpat_array (_, _, pats) -> List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats) #elif OCAML_VERSION < (5,4,0) | Tpat_array pats -> From 4074abda66ff8b95de5189134a4c1f5d49a24e6d Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 09:15:21 -0400 Subject: [PATCH 11/25] Support OxCaml labeled tuples (#10) --- src/document/generator.ml | 13 ++++++------- src/loader/cmi.ml | 8 +++++--- src/loader/cmt.ml | 2 +- src/loader/cmti.ml | 2 +- src/loader/ident_env.cppo.ml | 8 ++++---- src/search/html.ml | 4 ++-- 6 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index bcc3d08edb..5d6325272b 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -452,16 +452,15 @@ module Make (Syntax : SYNTAX) = struct in if not needs_parentheses then res else enclose ~l:"(" res ~r:")" | Tuple lst -> + let opt_label = function + None -> O.noop + | Some lbl -> O.txt lbl ++ O.txt ":" ++ O.cut + in let res = O.box_hv_no_indent (O.list lst ~sep:Syntax.Type.Tuple.element_separator - ~f:(fun (lbl, ty) -> - match lbl with - | None -> type_expr ~needs_parentheses:true ty - | Some lbl -> - tag "label" (O.txt lbl) - ++ O.txt ":" ++ O.cut - ++ type_expr ~needs_parentheses:true ty)) + ~f:(fun (lbl, typ) -> + opt_label lbl ++ type_expr ~needs_parentheses:true typ)) in if Syntax.Type.Tuple.always_parenthesize || needs_parentheses then enclose ~l:"(" res ~r:")" diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 556273f533..7e4238dce0 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -62,6 +62,8 @@ module Compat = struct let eq_type = Types.eq_type #if OCAML_VERSION >= (5,4,0) let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [None,ty]) +#elif OCAML_VERSION = (5,2,0) + let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [None, ty]) #else let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [ty]) #endif @@ -86,7 +88,7 @@ module Compat = struct (** Create a new node pointing to [ty] that is printed in the same way as [ty]*) let invisible_wrap ty = - Btype.(newty2 generic_level (Ttuple [ty])) + Btype.(newty2 generic_level (Ttuple [None, ty])) #endif end @@ -238,7 +240,7 @@ let mark_type ty = | Tarrow(_, ty1, ty2, _) -> loop visited ty1; loop visited ty2 -#if OCAML_VERSION >= (5,4,0) +#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) | Ttuple tyl -> List.iter (fun (_lbl,x) -> loop visited x) tyl #else | Ttuple tyl -> List.iter (loop visited) tyl @@ -492,7 +494,7 @@ let rec read_type_expr env typ = let res = read_type_expr env res in Arrow(lbl, arg, res) | Ttuple typs -> -#if OCAML_VERSION >= (5,4,0) +#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) let typs = List.map (fun (lbl,x) -> lbl, read_type_expr env x) typs in #else let typs = List.map (fun x -> None, read_type_expr env x) typs in diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 5e3ce473f1..02feef6911 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -67,7 +67,7 @@ let rec read_pattern env parent doc pat = Value {id; source_loc; doc; type_; value} :: read_pattern env parent doc pat | Tpat_constant _ -> [] | Tpat_tuple pats -> -#if OCAML_VERSION >= (5, 4, 0) +#if OCAML_VERSION >= (5, 4, 0) || OCAML_VERSION = (5, 2, 0) let pats = List.map snd pats (* remove labels *) in #endif List.concat (List.map (read_pattern env parent doc) pats) diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 4d6c48c298..2516118517 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -66,7 +66,7 @@ let rec read_core_type env container ctyp = let res = read_core_type env container res in Arrow(lbl, arg, res) | Ttyp_tuple typs -> -#if OCAML_VERSION >= (5,4,0) +#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) let typs = List.map (fun (lbl,x) -> lbl, read_core_type env container x) typs in #else let typs = List.map (fun x -> None, read_core_type env container x) typs in diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 8f5406d77c..a911517f28 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -325,7 +325,7 @@ let rec read_pattern hide_item pat = #endif #if OCAML_VERSION = (5,2,0) | Tpat_array (_, _, pats) -> - List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats) + List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #elif OCAML_VERSION < (5,4,0) | Tpat_array pats -> List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) @@ -334,10 +334,10 @@ let rec read_pattern hide_item pat = List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #endif | Tpat_tuple pats -> -#if OCAML_VERSION < (5,4,0) - List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) -#else +#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats) +#else + List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #endif | Tpat_or(pat, _, _) | Tpat_variant(_, Some pat, _) diff --git a/src/search/html.ml b/src/search/html.ml index cb090f1f44..1d193522be 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -34,9 +34,9 @@ let display_constructor_args args = let open Odoc_model.Lang in match args with | TypeDecl.Constructor.Tuple args -> + let no_label arg = None, arg in (match args with - | _ :: _ :: _ -> - Some TypeExpr.(Tuple (List.map (fun x -> (None, x)) args)) + | _ :: _ :: _ -> Some TypeExpr.(Tuple (List.map no_label args)) | [ arg ] -> Some arg | _ -> None) |> map_option Text.of_type From c98917cdb9e778e613cb14ae28839d18f2f3808a Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 09:18:40 -0400 Subject: [PATCH 12/25] Support OxCaml call position arguments (#11) --- src/loader/cmi.ml | 7 ++++--- src/loader/cmi.mli | 2 +- src/loader/cmti.ml | 1 + 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 7e4238dce0..68d797ae69 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -115,9 +115,10 @@ let read_label lbl = | _ -> Some (Label lbl) #else match lbl with - | Asttypes.Nolabel -> None - | Asttypes.Labelled s -> Some (Label s) - | Asttypes.Optional s -> Some (Optional s) + | Types.Nolabel -> None + | Types.Labelled s -> Some (Label s) + | Types.Optional s -> Some (Optional s) + | Types.Position s -> (* FIXME: do better? *) Some (Label s) #endif (* Handle type variable names *) diff --git a/src/loader/cmi.mli b/src/loader/cmi.mli index 6075c8f4de..619d8493be 100644 --- a/src/loader/cmi.mli +++ b/src/loader/cmi.mli @@ -34,7 +34,7 @@ val read_interface : #if OCAML_VERSION < (4,3,0) val read_label : Asttypes.label -> Odoc_model.Lang.TypeExpr.label option #else -val read_label : Asttypes.arg_label -> Odoc_model.Lang.TypeExpr.label option +val read_label : Types.arg_label -> Odoc_model.Lang.TypeExpr.label option #endif val mark_type_expr : Types.type_expr -> unit diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 2516118517..4531ac9cd2 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -177,6 +177,7 @@ let rec read_core_type env container ctyp = (* TODO: adjust model *) read_core_type env container t #endif + | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, []) | Ttyp_of_kind _ -> assert false let read_value_description env parent vd = From 3749bd2003b8268bebf333e60164ee4d23b0de00 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 16 Jul 2025 10:42:46 -0400 Subject: [PATCH 13/25] Print source information in implementations (#13) --- src/model_desc/lang_desc.ml | 55 +++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index c0bd871dc5..3b276a8783 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -757,6 +757,60 @@ and child = | { Location_.value = Dir s; _ } -> C ("Dir", s, string) | { Location_.value = Module s; _ } -> C ("Module", s, string)) +(** {3 Source_info} *) + +and source_location_t : Paths.Identifier.SourceLocation.t t = + Indirect ((fun sl -> (sl :> Paths.Identifier.t)), identifier) + +and jump_to_impl_t = + let open Lang.Source_info in + Variant + (function + | Unresolved x -> C ("Unresolved", x, path) + | Resolved i -> C ("Resolved", i, source_location_t)) + +and jump_to_t = + let open Lang.Source_info in + Record + [ + F ("documentation", (fun t -> t.documentation), Option path); + F ("implementation", (fun t -> t.implementation), Option jump_to_impl_t); + ] + +and source_info_annotation_t = + let open Lang.Source_info in + Variant + (function + | Definition i -> C ("Definition", i, source_location_t) + | Value j -> C ("Value", (j :> Paths.Path.t jump_to), jump_to_t) + | Module j -> C ("Module", (j :> Paths.Path.t jump_to), jump_to_t) + | ModuleType j -> C ("ModuleType", (j :> Paths.Path.t jump_to), jump_to_t) + | Type j -> C ("Type", (j :> Paths.Path.t jump_to), jump_to_t)) + +and source_info_point_in_file_t : Lang.Source_info.point_in_file t = + let open Lang.Source_info in + Record + [ + F ("pos_lnum", (fun t -> t.pos_lnum), int); + F ("pos_cnum", (fun t -> t.pos_cnum), int); + ] + +and source_info_location_in_file_t : Lang.Source_info.location_in_file t = + let open Lang.Source_info in + Record + [ + F ("loc_start", (fun t -> t.loc_start), source_info_point_in_file_t); + F ("loc_end", (fun t -> t.loc_end), source_info_point_in_file_t); + ] + +and source_info_annotation_with_pos_t : Lang.Source_info.annotation Lang.Source_info.with_pos t = + Pair (source_info_annotation_t, source_info_location_in_file_t) + +and source_info_t : Lang.Source_info.t t = + List source_info_annotation_with_pos_t + +(** {3 Implementation} *) + and implementation_t = let open Lang.Implementation in Record @@ -764,6 +818,7 @@ and implementation_t = F ("id", (fun t -> t.id), Option identifier); F ("digest", (fun t -> t.digest), Digest.t); F ("root", (fun t -> t.root), root); + F ("source_info", (fun t -> t.source_info), source_info_t); ] and asset_t = From b4b3039e6a506c882eadd3866253e93ecc1da5fb Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 17 Jul 2025 07:23:13 -0400 Subject: [PATCH 14/25] Add source locations to more places (#14) --- src/document/generator.ml | 4 +-- src/index/entry.ml | 5 ++-- src/index/entry.mli | 2 ++ src/index/skeleton.ml | 41 ++++++++++++++++------------ src/index/skeleton_of.ml | 8 +++--- src/loader/cmi.ml | 28 ++++++++++++++----- src/loader/cmt.ml | 12 +++++--- src/loader/cmti.ml | 21 +++++++++----- src/loader/implementation.ml | 11 +++++++- src/loader/odoc_loader.ml | 7 +++++ src/model/lang.ml | 25 ++++++++++++++++- src/search/html.ml | 4 +-- src/search/json_index/json_search.ml | 2 +- src/xref2/component.ml | 16 +++++++++++ src/xref2/component.mli | 7 +++++ src/xref2/env.ml | 4 +++ src/xref2/lang_of.ml | 7 +++++ src/xref2/subst.ml | 2 +- test/xref2/lib/common.cppo.ml | 1 + 19 files changed, 158 insertions(+), 49 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 5d6325272b..827ce86e2e 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -289,8 +289,8 @@ module Make (Syntax : SYNTAX) = struct let source id syntax_info infos source_code = let url = path id in - let mapper (info, loc) = - match info_of_info info with Some x -> Some (x, loc) | None -> None + let mapper (info, (loc : Lang.Source_info.location_in_file)) = + match info_of_info info with Some x -> Some (x, (loc.loc_start.pos_cnum, loc.loc_end.pos_cnum)) | None -> None in let infos = Odoc_utils.List.filter_map mapper infos in let syntax_info = diff --git a/src/index/entry.ml b/src/index/entry.ml index b81b6ca9f6..b89dd5cf0a 100644 --- a/src/index/entry.ml +++ b/src/index/entry.ml @@ -64,8 +64,9 @@ type t = { id : Odoc_model.Paths.Identifier.Any.t; doc : Odoc_model.Comment.elements; kind : kind; + source_loc : Odoc_model.Lang.Source_loc_jane.t option; } -let entry ~id ~doc ~kind = +let entry ~id ~doc ~kind ~source_loc = let id = (id :> Odoc_model.Paths.Identifier.Any.t) in - { id; kind; doc } + { id; kind; doc; source_loc } diff --git a/src/index/entry.mli b/src/index/entry.mli index b2704f5367..be9ed43e7f 100644 --- a/src/index/entry.mli +++ b/src/index/entry.mli @@ -62,10 +62,12 @@ type t = { id : Odoc_model.Paths.Identifier.Any.t; doc : Odoc_model.Comment.elements; kind : kind; + source_loc : Odoc_model.Lang.Source_loc_jane.t option; } val entry : id:[< Odoc_model.Paths.Identifier.Any.t_pv ] Odoc_model.Paths.Identifier.id -> doc:Odoc_model.Comment.elements -> kind:kind -> + source_loc:Odoc_model.Lang.Source_loc_jane.t option -> t diff --git a/src/index/skeleton.ml b/src/index/skeleton.ml index 67cf5cd045..c8a3573087 100644 --- a/src/index/skeleton.ml +++ b/src/index/skeleton.ml @@ -14,12 +14,14 @@ module Entry = struct match u.content with Pack _ -> [] | Module m -> m.doc.elements in Entry.entry ~id:u.id ~doc ~kind:(Module { has_expansion }) + ~source_loc:u.source_loc_jane let of_module (m : Module.t) = let has_expansion = match m.type_ with Alias (_, None) -> false | _ -> true in Entry.entry ~id:m.id ~doc:m.doc.elements ~kind:(Module { has_expansion }) + ~source_loc:m.source_loc_jane let of_module_type (mt : ModuleType.t) = let has_expansion = @@ -35,7 +37,7 @@ module Entry = struct | _ -> true in Entry.entry ~id:mt.id ~doc:mt.doc.elements - ~kind:(ModuleType { has_expansion }) + ~kind:(ModuleType { has_expansion }) ~source_loc:mt.source_loc_jane let of_type_decl (td : TypeDecl.t) = let kind = @@ -47,6 +49,7 @@ module Entry = struct } in Entry.entry ~id:td.id ~doc:td.doc.elements ~kind + ~source_loc:td.source_loc_jane let varify_params = List.mapi (fun i param -> @@ -54,7 +57,7 @@ module Entry = struct | Var name -> TypeExpr.Var name | Any -> Var (Printf.sprintf "tv_%i" i)) - let of_constructor id_parent params (c : TypeDecl.Constructor.t) = + let of_constructor id_parent params source_loc (c : TypeDecl.Constructor.t) = let args = c.args in let res = match c.res with @@ -67,9 +70,9 @@ module Entry = struct params ) in let kind = Entry.Constructor { args; res } in - Entry.entry ~id:c.id ~doc:c.doc.elements ~kind + Entry.entry ~id:c.id ~doc:c.doc.elements ~kind ~source_loc - let of_field id_parent params (field : TypeDecl.Field.t) = + let of_field id_parent params source_loc (field : TypeDecl.Field.t) = let params = varify_params params in let parent_type = TypeExpr.Constr @@ -81,7 +84,7 @@ module Entry = struct Entry.Field { mutable_ = field.mutable_; type_ = field.type_; parent_type } in - Entry.entry ~id:field.id ~doc:field.doc.elements ~kind + Entry.entry ~id:field.id ~doc:field.doc.elements ~kind ~source_loc let of_exception (exc : Exception.t) = let res = @@ -94,10 +97,11 @@ module Entry = struct in let kind = Entry.Exception { args = exc.args; res } in Entry.entry ~id:exc.id ~doc:exc.doc.elements ~kind + ~source_loc:exc.source_loc_jane let of_value (v : Value.t) = let kind = Entry.Value { value = v.value; type_ = v.type_ } in - Entry.entry ~id:v.id ~doc:v.doc.elements ~kind + Entry.entry ~id:v.id ~doc:v.doc.elements ~kind ~source_loc:v.source_loc_jane let of_extension_constructor type_path params (v : Extension.Constructor.t) = let res = @@ -108,26 +112,29 @@ module Entry = struct TypeExpr.Constr (type_path, params) in let kind = Entry.ExtensionConstructor { args = v.args; res } in - Entry.entry ~id:v.id ~doc:v.doc.elements ~kind + Entry.entry ~id:v.id ~doc:v.doc.elements ~kind ~source_loc:None let of_class (cl : Class.t) = let kind = Entry.Class { virtual_ = cl.virtual_; params = cl.params } in Entry.entry ~id:cl.id ~doc:cl.doc.elements ~kind + ~source_loc:cl.source_loc_jane let of_class_type (ct : ClassType.t) = let kind = Entry.Class_type { virtual_ = ct.virtual_; params = ct.params } in Entry.entry ~id:ct.id ~doc:ct.doc.elements ~kind + ~source_loc:ct.source_loc_jane let of_method (m : Method.t) = let kind = Entry.Method { virtual_ = m.virtual_; private_ = m.private_; type_ = m.type_ } in - Entry.entry ~id:m.id ~doc:m.doc.elements ~kind + Entry.entry ~id:m.id ~doc:m.doc.elements ~kind ~source_loc:None - let of_docs id doc = Entry.entry ~id ~doc:doc.elements ~kind:Doc + let of_docs id source_loc doc = + Entry.entry ~id ~doc:doc.elements ~kind:Doc ~source_loc end let if_non_hidden id f = @@ -215,18 +222,18 @@ and type_decl td = match td.representation with | None -> [] | Some (Variant cl) -> - List.concat_map (constructor td.id td.equation.params) cl - | Some (Record fl) -> List.concat_map (field td.id td.equation.params) fl + List.concat_map (constructor td.id td.equation.params td.source_loc_jane) cl + | Some (Record fl) -> List.concat_map (field td.id td.equation.params td.source_loc_jane) fl | Some Extensible -> [] in [ { Tree.node = entry; children } ] -and constructor type_id params c = - let entry = Entry.of_constructor type_id params c in +and constructor type_id params source_loc c = + let entry = Entry.of_constructor type_id params source_loc c in [ Tree.leaf entry ] -and field type_id params f = - let entry = Entry.of_field type_id params f in +and field type_id params source_loc f = + let entry = Entry.of_field type_id params source_loc f in [ Tree.leaf entry ] and exception_ exc = @@ -263,7 +270,7 @@ and docs id d = match d with | `Stop -> [] | `Docs d -> - let entry = Entry.of_docs id d in + let entry = Entry.of_docs id None d in [ Tree.leaf entry ] and simple_expansion id s_e = @@ -312,5 +319,5 @@ let from_unit u = unit u let from_page (p : Page.t) = match p with | { name; content; _ } -> - let entry = Entry.of_docs name content in + let entry = Entry.of_docs name None content in Tree.leaf entry diff --git a/src/index/skeleton_of.ml b/src/index/skeleton_of.ml index 27a8e80e1d..07a6dbde73 100644 --- a/src/index/skeleton_of.ml +++ b/src/index/skeleton_of.ml @@ -43,11 +43,11 @@ let rec t_of_in_progress (dir : In_progress.in_progress) : t = let kind = Entry.Page page.Lang.Page.frontmatter in let doc = page.content.elements in let id = page.name in - Entry.entry ~kind ~doc ~id + Entry.entry ~kind ~doc ~id ~source_loc:None in let entry_of_impl id = let kind = Entry.Impl in - Entry.entry ~kind ~doc:[] ~id + Entry.entry ~kind ~doc:[] ~id ~source_loc:None in let children_order, index = match In_progress.index dir with @@ -60,14 +60,14 @@ let rec t_of_in_progress (dir : In_progress.in_progress) : t = match In_progress.root_dir dir with | Some id -> let kind = Entry.Dir in - Entry.entry ~kind ~doc:[] ~id + Entry.entry ~kind ~doc:[] ~id ~source_loc:None | None -> let id = (* root dir must have an index page *) Id.Mk.leaf_page (None, Names.PageName.make_std "index") in let kind = Entry.Dir in - Entry.entry ~kind ~doc:[] ~id + Entry.entry ~kind ~doc:[] ~id ~source_loc:None in (None, entry) in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 68d797ae69..09b80606d0 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -677,7 +677,9 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd = External primitives | _ -> assert false in - Value { Value.id; source_loc; doc; type_; value } + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + Value { Value.id; source_loc; doc; type_; value ; source_loc_jane } let read_label_declaration env parent ld = let open TypeDecl.Field in @@ -824,7 +826,9 @@ let read_type_declaration env parent id decl = in let private_ = (decl.type_private = Private) in let equation = Equation.{params; manifest; constraints; private_} in - {id; source_loc; doc; canonical; equation; representation} + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + {id; source_loc; doc; canonical; equation; representation; source_loc_jane } let read_extension_constructor env parent id ext = let open Extension.Constructor in @@ -871,7 +875,9 @@ let read_exception env parent id ext = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args in let res = opt_map (read_type_expr env) ext.ext_ret_type in - {id; source_loc; doc; args; res} + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + {id; source_loc; doc; args; res; source_loc_jane} let read_method env parent concrete (name, kind, typ) = let open Method in @@ -969,7 +975,9 @@ let read_class_type_declaration env parent id cltd = read_class_signature env (id :> Identifier.ClassSignature.t) cltd.clty_params cltd.clty_type in let virtual_ = read_virtual cltd.clty_type in - { id; source_loc; doc; virtual_; params; expr; expansion = None } + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + { id; source_loc; doc; virtual_; params; expr; expansion = None ; source_loc_jane} let rec read_class_type env parent params = let open Class in function @@ -1007,7 +1015,9 @@ let read_class_declaration env parent id cld = read_class_type env (id :> Identifier.ClassSignature.t) cld.cty_params cld.cty_type in let virtual_ = cld.cty_new = None in - { id; source_loc; doc; virtual_; params; type_; expansion = None } + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + { id; source_loc; doc; virtual_; params; type_; expansion = None ; source_loc_jane} let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = let open ModuleType in @@ -1053,7 +1063,9 @@ and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_ let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in - {id; source_loc; doc; canonical; expr } + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + {id; source_loc; doc; canonical; expr ; source_loc_jane} and read_module_declaration env parent ident (md : Odoc_model.Compat.module_declaration) = let open Module in @@ -1072,7 +1084,9 @@ and read_module_declaration env parent ident (md : Odoc_model.Compat.module_decl | Some _ -> false | None -> Odoc_model.Names.contains_double_underscore (Ident.name ident) in - {id; source_loc; doc; type_; canonical; hidden } + (* Source location is not trustworthy since it's a cmi so left as None *) + let source_loc_jane = None in + {id; source_loc; doc; type_; canonical; hidden ; source_loc_jane} and read_type_rec_status rec_status = let open Signature in diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 02feef6911..0b02f8f9c6 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -49,7 +49,8 @@ let rec read_pattern env parent doc pat = Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in - [Value {id; source_loc; doc; type_; value}] + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir pat.pat_loc) in + [Value {id; source_loc; doc; type_; value ; source_loc_jane }] #if OCAML_VERSION < (5,2, 0) | Tpat_alias(pat, id, _) -> #elif OCAML_VERSION = (5,2, 0) @@ -64,7 +65,8 @@ let rec read_pattern env parent doc pat = Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in - Value {id; source_loc; doc; type_; value} :: read_pattern env parent doc pat + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir pat.pat_loc) in + Value {id; source_loc; doc; type_; value ; source_loc_jane } :: read_pattern env parent doc pat | Tpat_constant _ -> [] | Tpat_tuple pats -> #if OCAML_VERSION >= (5, 4, 0) || OCAML_VERSION = (5, 2, 0) @@ -365,7 +367,8 @@ let read_class_declaration env parent cld = clparams in let type_ = read_class_expr env (id :> Identifier.ClassSignature.t) clparams cld.ci_expr in - { id; source_loc; doc; virtual_; params; type_; expansion = None } + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir cld.ci_loc) in + { id; source_loc; doc; virtual_; params; type_; expansion = None ; source_loc_jane} let read_class_declarations env parent clds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -485,7 +488,8 @@ and read_module_binding env parent mb = | Some _, _ -> false #endif in - Some {id; source_loc; doc; type_; canonical; hidden; } + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir mb.mb_loc) in + Some {id; source_loc; doc; type_; canonical; hidden; source_loc_jane} and read_module_bindings env parent mbs = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 4531ac9cd2..4d17810c15 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -194,7 +194,8 @@ let read_value_description env parent vd = | [] -> Value.Abstract | primitives -> External primitives in - Value { Value.id; source_loc; doc; type_; value } + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir vd.val_loc) in + Value { Value.id; source_loc; doc; type_; value ; source_loc_jane } let read_type_parameter (ctyp, var_and_injectivity) = let open TypeDecl in @@ -303,7 +304,8 @@ let read_type_declaration env parent decl = let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in let equation = read_type_equation env container decl in let representation = read_type_kind env id decl.typ_kind in - {id; source_loc; doc; canonical; equation; representation} + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir decl.typ_loc) in + {id; source_loc; doc; canonical; equation; representation; source_loc_jane} let read_type_declarations env parent rec_flag decls = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -382,7 +384,8 @@ let read_exception env parent (ext : extension_constructor) = env container label_container args in let res = opt_map (read_core_type env label_container) res in - {id; source_loc; doc; args; res} + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir ext.ext_loc) in + {id; source_loc; doc; args; res; source_loc_jane} let rec read_class_type_field env parent ctf = let open ClassSignature in @@ -463,7 +466,8 @@ let read_class_type_declaration env parent cltd = let virtual_ = (cltd.ci_virt = Virtual) in let params = List.map read_type_parameter cltd.ci_params in let expr = read_class_signature env (id :> Identifier.ClassSignature.t) container cltd.ci_expr in - { id; source_loc; doc; virtual_; params; expr; expansion = None } + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir cltd.ci_loc) in + { id; source_loc; doc; virtual_; params; expr; expansion = None ; source_loc_jane } let read_class_type_declarations env parent cltds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -502,7 +506,8 @@ let read_class_description env parent cld = let virtual_ = (cld.ci_virt = Virtual) in let params = List.map read_type_parameter cld.ci_params in let type_ = read_class_type env (id :> Identifier.ClassSignature.t) container cld.ci_expr in - { id; source_loc; doc; virtual_; params; type_; expansion = None } + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir cld.ci_loc) in + { id; source_loc; doc; virtual_; params; type_; expansion = None ; source_loc_jane} let read_class_descriptions env parent clds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -653,7 +658,8 @@ and read_module_type_declaration env parent mtd = | None -> (None, canonical) in let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in - { id; source_loc; doc; canonical; expr } + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir mtd.mtd_loc) in + { id; source_loc; doc; canonical; expr ; source_loc_jane} and read_module_declaration env parent md = let open Module in @@ -692,7 +698,8 @@ and read_module_declaration env parent md = | _ -> false #endif in - Some {id; source_loc; doc; type_; canonical; hidden} + let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir md.md_loc) in + Some {id; source_loc; doc; type_; canonical; hidden; source_loc_jane} and read_module_declarations env parent mds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index bfa2c16ed3..26c6240bda 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -8,7 +8,16 @@ let rec is_persistent : Path.t -> bool = function | Path.Pextra_ty (p, _) -> is_persistent p #endif -let pos_of_loc loc = (loc.Location.loc_start.pos_cnum, loc.loc_end.pos_cnum) +let pos_of_loc (loc : Warnings.loc) = { + Odoc_model.Lang.Source_info.loc_start = { + pos_cnum = loc.loc_start.pos_cnum ; + pos_lnum = loc.loc_start.pos_lnum + } ; + loc_end = { + pos_cnum = loc.loc_start.pos_cnum ; + pos_lnum = loc.loc_start.pos_lnum + } +} let counter = let c = ref 0 in diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index 164c1af8c8..e6f0eda7cd 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -80,6 +80,12 @@ let make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id Some { Source.file; digest; build_dir } | _ -> None in + let source_loc_jane = + match sourcefile with + | Some (Some file, _, build_dir) -> + Some {Odoc_model.Lang.Source_loc_jane.filename = build_dir ^ "/" ^ file ; line_number = 1} + | _ -> None + in { id; root; @@ -93,6 +99,7 @@ let make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id linked = false; canonical; source_loc = None; + source_loc_jane } let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id diff --git a/src/model/lang.ml b/src/model/lang.ml index 7ec1d7e3bb..1425f43e3d 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -16,6 +16,15 @@ open Paths +module Source_loc_jane = struct + type t = { filename: string ; line_number: int } + + let of_location (build_dir : string) (loc: Location.t) = + let { Location.loc_start ; _ } = loc in + let { pos_fname ; pos_lnum ; _ } = loc_start in + { filename = build_dir ^ "/" ^ pos_fname ; line_number = pos_lnum } +end + (** {3 Modules} *) module rec Module : sig @@ -28,6 +37,7 @@ module rec Module : sig source_loc : Identifier.SourceLocation.t option; (** Identifier.SourceLocation might not be set when the module is artificially constructed from a functor argument. *) + source_loc_jane : Source_loc_jane.t option; doc : Comment.docs; type_ : decl; canonical : Path.Module.t option; @@ -116,6 +126,7 @@ and ModuleType : sig id : Identifier.ModuleType.t; source_loc : Identifier.SourceLocation.t option; (** Can be [None] for module types created by a type substitution. *) + source_loc_jane : Source_loc_jane.t option; doc : Comment.docs; canonical : Path.ModuleType.t option; expr : expr option; @@ -262,6 +273,7 @@ and TypeDecl : sig type t = { id : Identifier.Type.t; source_loc : Identifier.SourceLocation.t option; + source_loc_jane : Source_loc_jane.t option; doc : Comment.docs; canonical : Path.Type.t option; equation : Equation.t; @@ -299,6 +311,7 @@ and Exception : sig type t = { id : Identifier.Exception.t; source_loc : Identifier.SourceLocation.t option; + source_loc_jane : Source_loc_jane.t option; doc : Comment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -314,6 +327,7 @@ and Value : sig type t = { id : Identifier.Value.t; source_loc : Identifier.SourceLocation.t option; + source_loc_jane : Source_loc_jane.t option; value : value; doc : Comment.docs; type_ : TypeExpr.t; @@ -331,6 +345,7 @@ and Class : sig type t = { id : Identifier.Class.t; source_loc : Identifier.SourceLocation.t option; + source_loc_jane : Source_loc_jane.t option; doc : Comment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -350,6 +365,7 @@ and ClassType : sig type t = { id : Identifier.ClassType.t; source_loc : Identifier.SourceLocation.t option; + source_loc_jane : Source_loc_jane.t option; doc : Comment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -491,12 +507,19 @@ module rec Compilation_unit : sig expansion : Signature.t option; linked : bool; (** Whether this unit has been linked. *) source_loc : Identifier.SourceLocation.t option; + source_loc_jane : Source_loc_jane.t option; canonical : Path.Module.t option; } end = Compilation_unit module rec Source_info : sig + type point_in_file = { + pos_lnum : int; + pos_cnum : int; + } + type location_in_file = {loc_start : point_in_file ; loc_end: point_in_file} + type 'a jump_to_impl = | Unresolved of 'a | Resolved of Identifier.SourceLocation.t @@ -513,7 +536,7 @@ module rec Source_info : sig | ModuleType of Path.ModuleType.t jump_to | Type of Path.Type.t jump_to - type 'a with_pos = 'a * (int * int) + type 'a with_pos = 'a * location_in_file type t = annotation with_pos list end = diff --git a/src/search/html.ml b/src/search/html.ml index 1d193522be..f46819f8b3 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -4,7 +4,7 @@ open Odoc_model open Lang open Odoc_index -let url { Entry.id; kind; doc = _ } = +let url { Entry.id; kind; doc = _ ; source_loc = _} = let open Entry in let stop_before = (* Some module/module types/... might not have an expansion, so we need to @@ -222,7 +222,7 @@ let html_string_of_doc doc = doc |> of_doc |> Format.asprintf "%a" (Tyxml.Html.pp_elt ()) let of_entry (entry : Entry.t) = - let ({ id; doc; kind } : Entry.t) = entry in + let ({ id; doc; kind ; source_loc=_} : Entry.t) = entry in let rhs = rhs_of_kind kind in let prefix_name, name = names_of_id id in let prefix_name = Some prefix_name and name = Some name in diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index bb86107241..4299ab522f 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -135,7 +135,7 @@ let of_doc (doc : Odoc_model.Comment.elements) = let txt = Text.of_doc doc in `String txt -let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = +let of_entry ({ Entry.id; doc; kind ; source_loc = _} as entry) html occurrences = let j_id = of_id id in let doc = of_doc doc in let kind = diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 7dbc1b7487..9625d1201d 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -65,6 +65,7 @@ module rec Module : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; type_ : decl; canonical : Odoc_model.Paths.Path.Module.t option; @@ -156,6 +157,7 @@ end = and Exception : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -230,6 +232,7 @@ and ModuleType : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.ModuleType.t option; expr : expr option; @@ -278,6 +281,7 @@ and TypeDecl : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.Type.t option; equation : Equation.t; @@ -291,6 +295,7 @@ and Value : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; type_ : TypeExpr.t; value : value; @@ -362,6 +367,7 @@ and Class : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -378,6 +384,7 @@ and ClassType : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -2163,6 +2170,7 @@ module Of_Lang = struct let open Odoc_model.Lang.TypeDecl in { TypeDecl.source_loc = ty.source_loc; + source_loc_jane = ty.source_loc_jane; doc = docs ident_map ty.doc; canonical = ty.canonical; equation = type_equation ident_map ty.equation; @@ -2331,6 +2339,7 @@ module Of_Lang = struct let canonical = m.Odoc_model.Lang.Module.canonical in { Module.source_loc = m.source_loc; + source_loc_jane = m.source_loc_jane; doc = docs ident_map m.doc; type_; canonical; @@ -2397,6 +2406,7 @@ module Of_Lang = struct let res = Opt.map (type_expression ident_map) e.res in { Exception.source_loc = e.source_loc; + source_loc_jane = e.source_loc_jane; doc = docs ident_map e.doc; args; res; @@ -2504,6 +2514,7 @@ module Of_Lang = struct in { ModuleType.source_loc = m.source_loc; + source_loc_jane = m.source_loc_jane; doc = docs ident_map m.doc; canonical = m.canonical; expr; @@ -2516,6 +2527,7 @@ module Of_Lang = struct doc = docs ident_map v.doc; value = v.value; source_loc = v.source_loc; + source_loc_jane = v.source_loc_jane } and include_ ident_map i = @@ -2537,6 +2549,7 @@ module Of_Lang = struct let expansion = Opt.map (class_signature ident_map) c.expansion in { Class.source_loc = c.source_loc; + source_loc_jane = c.source_loc_jane; doc = docs ident_map c.doc; virtual_ = c.virtual_; params = c.params; @@ -2564,6 +2577,7 @@ module Of_Lang = struct let expansion = Opt.map (class_signature ident_map) t.expansion in { ClassType.source_loc = t.source_loc; + source_loc_jane = t.source_loc_jane; doc = docs ident_map t.doc; virtual_ = t.virtual_; params = t.params; @@ -2643,6 +2657,7 @@ module Of_Lang = struct let manifest = module_path ident_map t.manifest in { Module.source_loc = None; + source_loc_jane = None; doc = docs ident_map t.doc; type_ = Alias (manifest, None); canonical = None; @@ -2764,6 +2779,7 @@ end let module_of_functor_argument (arg : FunctorParameter.parameter) = { Module.source_loc = None; + source_loc_jane = None; doc = { elements = []; warnings_tag = None }; type_ = ModuleType arg.expr; canonical = None; diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 0719e2f1aa..62c4287931 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -63,6 +63,7 @@ module rec Module : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; type_ : decl; canonical : Odoc_model.Paths.Path.Module.t option; @@ -149,6 +150,7 @@ end and Exception : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -221,6 +223,7 @@ and ModuleType : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.ModuleType.t option; expr : expr option; @@ -268,6 +271,7 @@ and TypeDecl : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.Type.t option; equation : Equation.t; @@ -333,6 +337,7 @@ and Value : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; type_ : TypeExpr.t; value : value; @@ -346,6 +351,7 @@ and Class : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -361,6 +367,7 @@ and ClassType : sig type t = { source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option; + source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 0ef9963fe3..da9e7889f5 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -381,6 +381,7 @@ let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = { id; source_loc = None; + source_loc_jane = unit.source_loc_jane; doc = { elements = []; warnings_tag = None }; type_ = ModuleType (Signature s); canonical = unit.canonical; @@ -395,6 +396,7 @@ let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = { id; source_loc = None; + source_loc_jane = unit.source_loc_jane; doc = { elements = []; warnings_tag = None }; type_ = ModuleType @@ -656,6 +658,7 @@ let mk_functor_parameter module_type = Component.Module. { source_loc = None; + source_loc_jane = None; doc = { elements = []; warnings_tag = None }; type_; canonical = None; @@ -830,6 +833,7 @@ let open_module_type_substitution : Lang.ModuleTypeSubstitution.t -> t -> t = { id = t.id; source_loc = None; + source_loc_jane = None; doc = t.doc; expr = Some t.manifest; canonical = None; diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 2a19af0cf6..5d8a517166 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -489,6 +489,7 @@ and class_ map parent id c = { id = identifier; source_loc = c.source_loc; + source_loc_jane = c.source_loc_jane; doc = docs (parent :> Identifier.LabelParent.t) c.doc; virtual_ = c.virtual_; params = c.params; @@ -527,6 +528,7 @@ and class_type map parent id c = { Odoc_model.Lang.ClassType.id = identifier; source_loc = c.source_loc; + source_loc_jane = c.source_loc_jane; doc = docs (parent :> Identifier.LabelParent.t) c.doc; virtual_ = c.virtual_; params = c.params; @@ -687,6 +689,7 @@ and value_ map parent id v = { id = identifier; source_loc = v.source_loc; + source_loc_jane = v.source_loc_jane; doc = docs (parent :> Identifier.LabelParent.t) v.doc; type_ = type_expr map (parent :> Identifier.LabelParent.t) v.type_; value = v.value; @@ -730,6 +733,7 @@ and module_ map parent id m = { Odoc_model.Lang.Module.id; source_loc = m.source_loc; + source_loc_jane = m.source_loc_jane; doc = docs (parent :> Identifier.LabelParent.t) m.doc; type_ = module_decl map identifier m.type_; canonical = m.canonical; @@ -876,6 +880,7 @@ and module_type : { Odoc_model.Lang.ModuleType.id = identifier; source_loc = mty.source_loc; + source_loc_jane = mty.source_loc_jane; doc = docs (parent :> Identifier.LabelParent.t) mty.doc; canonical = mty.canonical; expr = Opt.map (module_type_expr map sig_id) mty.expr; @@ -944,6 +949,7 @@ and type_decl map parent id (t : Component.TypeDecl.t) : { id = identifier; source_loc = t.source_loc; + source_loc_jane = t.source_loc_jane; equation = type_decl_equation map (parent :> Identifier.FieldParent.t) t.equation; doc = docs (parent :> Identifier.LabelParent.t) t.doc; @@ -1073,6 +1079,7 @@ and exception_ map parent id (e : Component.Exception.t) : { id = identifier; source_loc = e.source_loc; + source_loc_jane = e.source_loc_jane; doc = docs (parent :> Identifier.LabelParent.t) e.doc; args = type_decl_constructor_argument map diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 7335b529d1..e4f987f4d2 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -580,7 +580,7 @@ and module_type s t = let expr = match t.expr with Some m -> Some (module_type_expr s m) | None -> None in - { expr; source_loc = t.source_loc; doc = t.doc; canonical = t.canonical } + { expr; source_loc = t.source_loc; source_loc_jane = t.source_loc_jane ; doc = t.doc; canonical = t.canonical } and module_type_substitution s t = let open Component.ModuleTypeSubstitution in diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index 0c07b94293..d731d020c5 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -606,6 +606,7 @@ let my_compilation_unit id (s : Odoc_model.Lang.Signature.t) = ; linked = false ; canonical = None ; source_loc = None + ; source_loc_jane = None } let mkresolver () = From d5084362e60d4e0d26a9f089e46d0882d2d56807 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 17 Jul 2025 07:36:34 -0400 Subject: [PATCH 15/25] Support OxCaml unboxed records (#15) --- src/document/ML.mli | 2 + src/document/comment.ml | 2 + src/document/generator.ml | 77 +++++++++++++++++++----- src/document/generator_signatures.ml | 2 + src/document/url.ml | 7 +++ src/document/url.mli | 1 + src/index/entry.ml | 1 + src/index/entry.mli | 1 + src/index/skeleton.ml | 19 ++++++ src/loader/cmi.ml | 19 ++++++ src/loader/cmt.ml | 9 +++ src/loader/cmti.ml | 22 +++++++ src/loader/ident_env.cppo.ml | 9 +++ src/loader/implementation.ml | 3 + src/model/lang.ml | 11 ++++ src/model/names.ml | 1 + src/model/names.mli | 2 + src/model/paths.ml | 41 +++++++++++++ src/model/paths.mli | 25 ++++++++ src/model/paths_types.ml | 38 ++++++++++++ src/model/reference.ml | 2 + src/model_desc/lang_desc.ml | 12 ++++ src/model_desc/paths_desc.ml | 15 +++++ src/model_desc/type_desc.ml | 3 + src/occurrences/table.ml | 10 ++++ src/search/html.ml | 5 ++ src/search/json_index/json_search.ml | 11 ++++ src/search/text.ml | 4 ++ src/search/text.mli | 2 + src/xref2/compile.ml | 8 +++ src/xref2/component.ml | 54 ++++++++++++++++- src/xref2/component.mli | 15 +++++ src/xref2/env.ml | 24 +++++++- src/xref2/env.mli | 4 +- src/xref2/errors.ml | 2 + src/xref2/expand_tools.ml | 1 + src/xref2/find.ml | 11 +++- src/xref2/find.mli | 4 +- src/xref2/ident.ml | 5 ++ src/xref2/lang_of.ml | 22 +++++++ src/xref2/link.ml | 19 ++++++ src/xref2/ref_tools.ml | 83 ++++++++++++++++++++++---- src/xref2/shape_tools.cppo.ml | 3 +- src/xref2/subst.ml | 9 +++ test/odoc_print/type_desc_to_yojson.ml | 3 + 45 files changed, 589 insertions(+), 34 deletions(-) diff --git a/src/document/ML.mli b/src/document/ML.mli index f3a18826b2..60d47859db 100644 --- a/src/document/ML.mli +++ b/src/document/ML.mli @@ -30,3 +30,5 @@ val implementation : val type_expr : ?needs_parentheses:bool -> Lang.TypeExpr.t -> Codefmt.t val record : Lang.TypeDecl.Field.t list -> Types.DocumentedSrc.one list + +val unboxed_record : Lang.TypeDecl.UnboxedField.t list -> Types.DocumentedSrc.one list diff --git a/src/document/comment.ml b/src/document/comment.ml index 6cf37dccd4..a7ce4ae854 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -44,6 +44,7 @@ module Reference = struct | `PolyConstructor (r, s) -> render_resolved (r :> t) ^ ".`" ^ ConstructorName.to_string s | `Field (r, s) -> render_resolved (r :> t) ^ "." ^ FieldName.to_string s + | `UnboxedField (r, s) -> render_resolved (r :> t) ^ "." ^ UnboxedFieldName.to_string s | `Extension (r, s) -> render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s | `ExtensionDecl (r, _, s) -> @@ -88,6 +89,7 @@ module Reference = struct | `Constructor (p, f) -> render_unresolved (p :> t) ^ "." ^ ConstructorName.to_string f | `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f + | `UnboxedField (p, f) -> render_unresolved (p :> t) ^ "." ^ UnboxedFieldName.to_string f | `Extension (p, f) -> render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f | `ExtensionDecl (p, f) -> diff --git a/src/document/generator.ml b/src/document/generator.ml index 827ce86e2e..831cc8a302 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -410,6 +410,22 @@ module Make (Syntax : SYNTAX) = struct in Syntax.Type.handle_constructor_params path (O.box_hv params) + and tuple ?(needs_parentheses = false) ~boxed lst = + let opt_label = function + None -> O.noop + | Some lbl -> O.txt lbl ++ O.txt ":" ++ O.cut + in + let res = + O.box_hv_no_indent + (O.list lst ~sep:Syntax.Type.Tuple.element_separator + ~f:(fun (lbl, typ) -> + opt_label lbl ++ type_expr ~needs_parentheses:true typ)) + in + let lparen = if boxed then "(" else "#(" in + if Syntax.Type.Tuple.always_parenthesize || needs_parentheses || not boxed then + enclose ~l:lparen res ~r:")" + else res + and type_expr ?(needs_parentheses = false) (t : Odoc_model.Lang.TypeExpr.t) = let enclose_parens_if_needed res = @@ -451,20 +467,8 @@ module Make (Syntax : SYNTAX) = struct ++ O.sp ++ type_expr dst in if not needs_parentheses then res else enclose ~l:"(" res ~r:")" - | Tuple lst -> - let opt_label = function - None -> O.noop - | Some lbl -> O.txt lbl ++ O.txt ":" ++ O.cut - in - let res = - O.box_hv_no_indent - (O.list lst ~sep:Syntax.Type.Tuple.element_separator - ~f:(fun (lbl, typ) -> - opt_label lbl ++ type_expr ~needs_parentheses:true typ)) - in - if Syntax.Type.Tuple.always_parenthesize || needs_parentheses then - enclose ~l:"(" res ~r:")" - else res + | Tuple lst -> tuple ~needs_parentheses ~boxed:true lst + | Unboxed_tuple lst -> tuple ~needs_parentheses ~boxed:false lst | Constr (path, args) -> let link = Link.from_path (path :> Paths.Path.t) in format_type_path ~delim:`parens args link @@ -514,6 +518,8 @@ module Make (Syntax : SYNTAX) = struct val record : Lang.TypeDecl.Field.t list -> DocumentedSrc.one list + val unboxed_record : Lang.TypeDecl.UnboxedField.t list -> DocumentedSrc.one list + val exn : Lang.Exception.t -> Item.t val format_params : @@ -565,6 +571,46 @@ module Make (Syntax : SYNTAX) = struct in content + let unboxed_record fields = + let field mutable_ id typ = + let url = Url.from_identifier ~stop_before:true id in + let name = Paths.Identifier.name id in + let attrs = + [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] + in + let cell = + (* O.td ~a:[ O.a_class ["def"; kind ] ] + * [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] [] + * ; *) + O.code + ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop) + ++ O.txt name + ++ O.txt Syntax.Type.annotation_separator + ++ type_expr typ + ++ O.txt Syntax.Type.Record.field_separator) + (* ] *) + in + (url, attrs, cell) + in + let rows = + fields + |> List.map (fun fld -> + let open Odoc_model.Lang.TypeDecl.UnboxedField in + let url, attrs, code = + field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_ + in + let anchor = Some url in + let doc = fld.doc.elements in + let rhs = Comment.to_ir doc in + let doc = if not (Comment.has_doc doc) then [] else rhs in + let markers = Syntax.Comment.markers in + DocumentedSrc.Documented { anchor; attrs; code; doc; markers }) + in + let content = + O.documentedSrc (O.txt "#{") @ rows @ O.documentedSrc (O.txt "}") + in + content + let constructor : Paths.Identifier.t -> Odoc_model.Lang.TypeDecl.Constructor.argument -> @@ -885,6 +931,7 @@ module Make (Syntax : SYNTAX) = struct | Extensible -> O.documentedSrc (O.txt "..") | Variant cstrs -> variant cstrs | Record fields -> record fields + | Record_unboxed_product fields -> unboxed_record fields in if List.length content > 0 then O.documentedSrc @@ -1845,4 +1892,6 @@ module Make (Syntax : SYNTAX) = struct let type_expr = type_expr let record = record + + let unboxed_record = unboxed_record end diff --git a/src/document/generator_signatures.ml b/src/document/generator_signatures.ml index d8dea2ab3f..18326f0838 100644 --- a/src/document/generator_signatures.ml +++ b/src/document/generator_signatures.ml @@ -114,4 +114,6 @@ module type GENERATOR = sig val type_expr : ?needs_parentheses:bool -> Lang.TypeExpr.t -> text val record : Lang.TypeDecl.Field.t list -> DocumentedSrc.one list + + val unboxed_record : Lang.TypeDecl.UnboxedField.t list -> DocumentedSrc.one list end diff --git a/src/document/url.ml b/src/document/url.ml index b53bc32f37..87f1fce429 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -231,6 +231,7 @@ module Anchor = struct | `Val | `Constructor | `Field + | `UnboxedField | `SourceAnchor ] let string_of_kind : kind -> string = function @@ -244,6 +245,7 @@ module Anchor = struct | `Val -> "val" | `Constructor -> "constructor" | `Field -> "field" + | `UnboxedField -> "unboxed-field" | `SourceAnchor -> "source-anchor" let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind) @@ -358,6 +360,11 @@ module Anchor = struct let kind = `Field in let suffix = FieldName.to_string name in add_suffix ~kind page suffix + | { iv = `UnboxedField (parent, name); _ } -> + let page = from_identifier (parent :> Identifier.t) in + let kind = `UnboxedField in + let suffix = UnboxedFieldName.to_string name in + add_suffix ~kind page suffix | { iv = `Label (parent, anchor); _ } -> ( let str_name = LabelName.to_string anchor in (* [Identifier.LabelParent.t] contains datatypes. [`CoreType] can't diff --git a/src/document/url.mli b/src/document/url.mli index f46ae62688..b56292f208 100644 --- a/src/document/url.mli +++ b/src/document/url.mli @@ -68,6 +68,7 @@ module Anchor : sig | `Val | `Constructor | `Field + | `UnboxedField | `SourceAnchor ] val pp_kind : Format.formatter -> kind -> unit diff --git a/src/index/entry.ml b/src/index/entry.ml index b89dd5cf0a..36f4ce3f14 100644 --- a/src/index/entry.ml +++ b/src/index/entry.ml @@ -56,6 +56,7 @@ type kind = | ModuleType of module_entry | Constructor of constructor_entry | Field of field_entry + | UnboxedField of field_entry | Page of Odoc_model.Frontmatter.t | Impl | Dir diff --git a/src/index/entry.mli b/src/index/entry.mli index be9ed43e7f..70a2405e12 100644 --- a/src/index/entry.mli +++ b/src/index/entry.mli @@ -54,6 +54,7 @@ type kind = | ModuleType of module_entry | Constructor of constructor_entry | Field of field_entry + | UnboxedField of field_entry | Page of Odoc_model.Frontmatter.t | Impl | Dir diff --git a/src/index/skeleton.ml b/src/index/skeleton.ml index c8a3573087..30350eddb7 100644 --- a/src/index/skeleton.ml +++ b/src/index/skeleton.ml @@ -86,6 +86,19 @@ module Entry = struct in Entry.entry ~id:field.id ~doc:field.doc.elements ~kind ~source_loc + let of_unboxed_field id_parent params source_loc (field : TypeDecl.UnboxedField.t) = + let params = varify_params params in + let parent_type = + TypeExpr.Constr + ( `Identifier + ((id_parent :> Odoc_model.Paths.Identifier.Path.Type.t), false), + params ) + in + let kind = + Entry.UnboxedField { mutable_ = field.mutable_; type_ = field.type_; parent_type } + in + Entry.entry ~id:field.id ~doc:field.doc.elements ~kind ~source_loc + let of_exception (exc : Exception.t) = let res = match exc.res with @@ -224,6 +237,8 @@ and type_decl td = | Some (Variant cl) -> List.concat_map (constructor td.id td.equation.params td.source_loc_jane) cl | Some (Record fl) -> List.concat_map (field td.id td.equation.params td.source_loc_jane) fl + | Some (Record_unboxed_product fl) -> + List.concat_map (unboxed_field td.id td.equation.params td.source_loc_jane) fl | Some Extensible -> [] in [ { Tree.node = entry; children } ] @@ -236,6 +251,10 @@ and field type_id params source_loc f = let entry = Entry.of_field type_id params source_loc f in [ Tree.leaf entry ] +and unboxed_field type_id params source_loc f = + let entry = Entry.of_unboxed_field type_id params source_loc f in + [ Tree.leaf entry ] + and exception_ exc = if_non_hidden exc.id @@ fun () -> let entry = Entry.of_exception exc in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 09b80606d0..bce9a5bab8 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -245,6 +245,9 @@ let mark_type ty = | Ttuple tyl -> List.iter (fun (_lbl,x) -> loop visited x) tyl #else | Ttuple tyl -> List.iter (loop visited) tyl +#endif +#if OCAML_VERSION = (5,2,0) + | Tunboxed_tuple tyl -> List.iter (fun (_, ty) -> loop visited ty) tyl #endif | Tconstr(_, tyl, _) -> List.iter (loop visited) tyl @@ -391,6 +394,8 @@ let mark_type_kind = function cds | Type_record(lds, _, _) -> List.iter (fun ld -> mark_type ld.ld_type) lds + | Type_record_unboxed_product(lds, _, _) -> + List.iter (fun ld -> mark_type ld.ld_type) lds | Type_open -> () let mark_type_declaration decl = @@ -501,6 +506,11 @@ let rec read_type_expr env typ = let typs = List.map (fun x -> None, read_type_expr env x) typs in #endif Tuple typs +#if OCAML_VERSION = (5,2,0) + | Tunboxed_tuple typs -> + let typs = List.map (fun (l,t) -> l, read_type_expr env t) typs in + Unboxed_tuple typs +#endif | Tconstr(p, params, _) -> let p = Env.Path.read_type env.ident_env p in let params = List.map (read_type_expr env) params in @@ -743,6 +753,13 @@ let read_type_kind env parent = lbls in Some (Record lbls) + | Type_record_unboxed_product(lbls, _, _) -> + let lbls = + List.map + (read_label_declaration env (parent :> Identifier.FieldParent.t)) + lbls + in + Some (Record lbls) | Type_open -> Some Extensible let read_injectivity var = @@ -811,6 +828,8 @@ let read_type_declaration env parent id decl = decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private + | Type_record_unboxed_product _ -> + decl.type_private = Private #if OCAML_VERSION >= (4,13,0) | Type_variant (tll,_,_) -> #else diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 0b02f8f9c6..748eaec8c9 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -73,6 +73,10 @@ let rec read_pattern env parent doc pat = let pats = List.map snd pats (* remove labels *) in #endif List.concat (List.map (read_pattern env parent doc) pats) +#if OCAML_VERSION = (5, 2, 0) + | Tpat_unboxed_tuple pats -> + List.concat (List.map (fun (_, p, _) -> read_pattern env parent doc p) pats) +#endif #if OCAML_VERSION < (4, 13, 0) | Tpat_construct(_, _, pats) -> #else @@ -88,6 +92,11 @@ let rec read_pattern env parent doc pat = (fun (_, _, pat) -> read_pattern env parent doc pat) pats) #if OCAML_VERSION = (5, 2, 0) + | Tpat_record_unboxed_product(pats, _) -> + List.concat + (List.map + (fun (_, _, pat) -> read_pattern env parent doc pat) + pats) | Tpat_array (_, _, pats) -> #elif OCAML_VERSION < (5, 4, 0) | Tpat_array pats -> diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 4d17810c15..7ec6897118 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -31,6 +31,7 @@ type env = Cmi.env = { warnings_tag : string option; } +let cmti_builddir : string ref = ref "" let read_module_expr : (env -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset") let opt_map f = function @@ -72,6 +73,11 @@ let rec read_core_type env container ctyp = let typs = List.map (fun x -> None, read_core_type env container x) typs in #endif Tuple typs +#if OCAML_VERSION = (5,2,0) + | Ttyp_unboxed_tuple typs -> + let typs = List.map (fun (l, t) -> l, read_core_type env container t) typs in + Unboxed_tuple typs +#endif | Ttyp_constr(p, _, params) -> let p = Env.Path.read_type env.ident_env p in let params = List.map (read_core_type env container) params in @@ -241,6 +247,16 @@ let read_label_declaration env parent label_parent ld = let type_ = read_core_type env label_parent ld.ld_type in {id; doc; mutable_; type_} +let read_unboxed_label_declaration env parent label_parent ld = + let open TypeDecl.UnboxedField in + let open Odoc_model.Names in + let name = Ident.name ld.ld_id in + let id = Identifier.Mk.unboxed_field(parent, UnboxedFieldName.make_std name) in + let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in + let mutable_ = Types.is_mutable ld.ld_mutable in + let type_ = read_core_type env label_parent ld.ld_type in + {id; doc; mutable_; type_} + let read_constructor_declaration_arguments env parent label_parent arg = let open TypeDecl.Constructor in #if OCAML_VERSION < (4,3,0) @@ -279,6 +295,12 @@ let read_type_kind env parent = let lbls = List.map (read_label_declaration env parent label_parent) lbls in Some (Record lbls) + | Ttype_record_unboxed_product lbls -> + let parent = (parent :> Identifier.UnboxedFieldParent.t) in + let label_parent = (parent :> Identifier.LabelParent.t) in + let lbls = + List.map (read_unboxed_label_declaration env parent label_parent) lbls in + Some (Record_unboxed_product lbls) | Ttype_open -> Some Extensible let read_type_equation env container decl = diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index a911517f28..8bdab8aa3a 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -119,6 +119,7 @@ and extract_signature_type_items_extract vis ~hidden item rest = | Types.Type_abstract _ -> [] #endif | Type_record (_, _, _) -> [] + | Type_record_unboxed_product (_, _, _) -> [] #if OCAML_VERSION < (4,13,0) | Type_variant cstrs -> #else @@ -210,6 +211,7 @@ let rec extract_signature_tree_items : bool -> Typedtree.signature_item list -> Ttype_abstract -> [] | Ttype_variant constrs -> List.map (fun c -> `Constructor (c.cd_id, decl.typ_id, Some c.cd_loc)) constrs | Ttype_record _ -> [] + | Ttype_record_unboxed_product _ -> [] | Ttype_open -> [] ) decls @ extract_signature_tree_items hide_item rest @@ -318,6 +320,8 @@ let rec read_pattern hide_item pat = `Value(id, hide_item, Some loc.loc) :: read_pattern hide_item pat | Tpat_record(pats, _) -> List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats) + | Tpat_record_unboxed_product(pats, _) -> + List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats) #if OCAML_VERSION < (4,13,0) | Tpat_construct(_, _, pats) #else @@ -338,6 +342,10 @@ let rec read_pattern hide_item pat = List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats) #else List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) +#endif +#if OCAML_VERSION = (5,2,0) + | Tpat_unboxed_tuple pats -> + List.concat (List.map (fun (_, pat, _) -> read_pattern hide_item pat) pats) #endif | Tpat_or(pat, _, _) | Tpat_variant(_, Some pat, _) @@ -361,6 +369,7 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list -> Ttype_abstract -> [] | Ttype_variant constrs -> List.map (fun c -> `Constructor (c.cd_id, decl.typ_id, Some c.cd_loc)) constrs | Ttype_record _ -> [] + | Ttype_record_unboxed_product _ -> [] | Ttype_open -> [] )) decls @ extract_structure_tree_items hide_item rest diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 26c6240bda..d7c699ba96 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -218,6 +218,9 @@ let anchor_of_identifier id = | `Field (parent, name) -> let anchor = anchor `Field (FieldName.to_string name) in continue anchor parent + | `UnboxedField (parent, name) -> + let anchor = anchor `UnboxedField (UnboxedFieldName.to_string name) in + continue anchor parent | `SourceLocationMod _ -> assert false | `Result parent -> anchor_of_identifier acc (parent :> Identifier.t) | `SourceLocationInternal _ -> assert false diff --git a/src/model/lang.ml b/src/model/lang.ml index 1425f43e3d..a33b8c6703 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -233,6 +233,15 @@ and TypeDecl : sig } end + module UnboxedField : sig + type t = { + id : Identifier.UnboxedField.t; + doc : Comment.docs; + mutable_ : bool; + type_ : TypeExpr.t; + } + end + module Constructor : sig type argument = Tuple of TypeExpr.t list | Record of Field.t list @@ -248,6 +257,7 @@ and TypeDecl : sig type t = | Variant of Constructor.t list | Record of Field.t list + | Record_unboxed_product of UnboxedField.t list | Extensible end @@ -465,6 +475,7 @@ and TypeExpr : sig | Alias of t * string | Arrow of label option * t * t | Tuple of (string option * t) list + | Unboxed_tuple of (string option * t) list | Constr of Path.Type.t * t list | Polymorphic_variant of TypeExpr.Polymorphic_variant.t | Object of TypeExpr.Object.t diff --git a/src/model/names.ml b/src/model/names.ml index ace399dbe4..7a2049f609 100644 --- a/src/model/names.ml +++ b/src/model/names.ml @@ -164,6 +164,7 @@ module ModuleTypeName = Name module TypeName = Name module ConstructorName = SimpleName module FieldName = SimpleName +module UnboxedFieldName = SimpleName module ExtensionName = SimpleName module ExceptionName = SimpleName module ValueName = Name diff --git a/src/model/names.mli b/src/model/names.mli index 1a4ad2c07c..2132dbd322 100644 --- a/src/model/names.mli +++ b/src/model/names.mli @@ -83,6 +83,8 @@ module ConstructorName : SimpleName module FieldName : SimpleName +module UnboxedFieldName : SimpleName + module ExtensionName : SimpleName module ExceptionName : SimpleName diff --git a/src/model/paths.ml b/src/model/paths.ml index dd5b9b80a3..a3ec2a1dae 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -41,6 +41,7 @@ module Identifier = struct | `Type (_, name) -> TypeName.to_string name | `Constructor (_, name) -> ConstructorName.to_string name | `Field (_, name) -> FieldName.to_string name + | `UnboxedField (_, name) -> UnboxedFieldName.to_string name | `Extension (_, name) -> ExtensionName.to_string name | `ExtensionDecl (_, _, name) -> ExtensionName.to_string name | `Exception (_, name) -> ExceptionName.to_string name @@ -71,6 +72,7 @@ module Identifier = struct | `Type (_, name) -> TypeName.is_hidden name | `Constructor (parent, _) -> is_hidden (parent :> t) | `Field (parent, _) -> is_hidden (parent :> t) + | `UnboxedField (parent, _) -> is_hidden (parent :> t) | `Extension (parent, _) -> is_hidden (parent :> t) | `ExtensionDecl (parent, _, _) -> is_hidden (parent :> t) | `Exception (parent, _) -> is_hidden (parent :> t) @@ -109,6 +111,8 @@ module Identifier = struct ConstructorName.to_string name :: full_name_aux (parent :> t) | `Field (parent, name) -> FieldName.to_string name :: full_name_aux (parent :> t) + | `UnboxedField (parent, name) -> + UnboxedFieldName.to_string name :: full_name_aux (parent :> t) | `Extension (parent, name) -> ExtensionName.to_string name :: full_name_aux (parent :> t) | `ExtensionDecl (parent, _, name) -> @@ -165,6 +169,7 @@ module Identifier = struct (p : class_signature :> label_parent) | { iv = `Constructor (p, _); _ } -> (p : datatype :> label_parent) | { iv = `Field (p, _); _ } -> (p : field_parent :> label_parent) + | { iv = `UnboxedField (p, _); _ } -> (p : unboxed_field_parent :> label_parent) let label_parent n = label_parent_aux (n :> Id.non_src) @@ -220,6 +225,11 @@ module Identifier = struct type t_pv = Paths_types.Identifier.field_parent_pv end + module UnboxedFieldParent = struct + type t = Paths_types.Identifier.unboxed_field_parent + type t_pv = Paths_types.Identifier.unboxed_field_parent_pv + end + module LabelParent = struct type t = Id.label_parent type t_pv = Id.label_parent_pv @@ -290,6 +300,11 @@ module Identifier = struct type t_pv = Id.field_pv end + module UnboxedField = struct + type t = Id.unboxed_field + type t_pv = Id.unboxed_field_pv + end + module Extension = struct type t = Id.extension type t_pv = Id.extension_pv @@ -562,6 +577,11 @@ module Identifier = struct [> `Field of FieldParent.t * FieldName.t ] id = mk_parent FieldName.to_string "fld" (fun (p, n) -> `Field (p, n)) + let unboxed_field : + UnboxedFieldParent.t * UnboxedFieldName.t -> + [> `UnboxedField of UnboxedFieldParent.t * UnboxedFieldName.t ] id = + mk_parent UnboxedFieldName.to_string "unboxedfld" (fun (p, n) -> `UnboxedField (p, n)) + let extension : Signature.t * ExtensionName.t -> [> `Extension of Signature.t * ExtensionName.t ] id = @@ -1012,6 +1032,11 @@ module Reference = struct | `Type _ as t -> (parent_type_identifier t :> Identifier.FieldParent.t option) + and unboxed_field_parent_identifier : unboxed_field_parent -> Identifier.UnboxedFieldParent.t option = + function + | `Identifier id -> Some id + | `Type _ as t -> (parent_type_identifier t :> Identifier.UnboxedFieldParent.t option) + and label_parent_identifier : label_parent -> Identifier.LabelParent.t option = function | `Identifier id -> Some id @@ -1024,6 +1049,10 @@ module Reference = struct and identifier : t -> Identifier.t option = function | `Identifier id -> Some id + | `UnboxedField (p, n) -> ( + match unboxed_field_parent_identifier p with + | None -> None + | Some p -> Some (Identifier.Mk.unboxed_field (p, n))) | ( `Alias _ | `AliasModuleType _ | `Module _ | `Hidden _ | `Type _ | `Class _ | `ClassType _ | `ModuleType _ ) as r -> (label_parent_identifier r :> Identifier.t option) @@ -1086,6 +1115,10 @@ module Reference = struct type t = Paths_types.Resolved_reference.field_parent end + module UnboxedFieldParent = struct + type t = Paths_types.Resolved_reference.unboxed_field_parent + end + module LabelParent = struct type t = Paths_types.Resolved_reference.label_parent end @@ -1110,6 +1143,10 @@ module Reference = struct type t = Paths_types.Resolved_reference.field end + module UnboxedField = struct + type t = Paths_types.Resolved_reference.unboxed_field + end + module Extension = struct type t = Paths_types.Resolved_reference.extension end @@ -1202,6 +1239,10 @@ module Reference = struct type t = Paths_types.Reference.field end + module UnboxedField = struct + type t = Paths_types.Reference.unboxed_field + end + module Extension = struct type t = Paths_types.Reference.extension end diff --git a/src/model/paths.mli b/src/model/paths.mli index a07608d996..99ccefcc07 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -80,6 +80,10 @@ module Identifier : sig type t = Id.field_parent type t_pv = Id.field_parent_pv end + module UnboxedFieldParent : sig + type t = Id.unboxed_field_parent + type t_pv = Id.unboxed_field_parent_pv + end module FunctorResult : sig type t = Id.functor_result @@ -96,6 +100,11 @@ module Identifier : sig type t_pv = Id.field_pv end + module UnboxedField : sig + type t = Id.unboxed_field + type t_pv = Id.unboxed_field_pv + end + module Extension : sig type t = Id.extension type t_pv = Id.extension_pv @@ -302,6 +311,10 @@ module Identifier : sig FieldParent.t * FieldName.t -> [> `Field of FieldParent.t * FieldName.t ] id + val unboxed_field : + UnboxedFieldParent.t * UnboxedFieldName.t -> + [> `UnboxedField of UnboxedFieldParent.t * UnboxedFieldName.t ] id + val extension : Signature.t * ExtensionName.t -> [> `Extension of Signature.t * ExtensionName.t ] id @@ -495,6 +508,10 @@ module rec Reference : sig type t = Paths_types.Resolved_reference.field_parent end + module UnboxedFieldParent : sig + type t = Paths_types.Resolved_reference.unboxed_field_parent + end + module LabelParent : sig type t = Paths_types.Resolved_reference.label_parent end @@ -519,6 +536,10 @@ module rec Reference : sig type t = Paths_types.Resolved_reference.field end + module UnboxedField : sig + type t = Paths_types.Resolved_reference.unboxed_field + end + module Extension : sig type t = Paths_types.Resolved_reference.extension end @@ -610,6 +631,10 @@ module rec Reference : sig type t = Paths_types.Reference.field end + module UnboxedField : sig + type t = Paths_types.Reference.unboxed_field + end + module Extension : sig type t = Paths_types.Reference.extension end diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index de155834db..eb24f8c4b7 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -92,6 +92,12 @@ module Identifier = struct and field_parent = field_parent_pv id (** @canonical Odoc_model.Paths.Identifier.FieldParent.t *) + type unboxed_field_parent_pv = datatype_pv + (** @canonical Odoc_model.Paths.Identifier.UnboxedFieldParent.t_pv *) + + and unboxed_field_parent = unboxed_field_parent_pv id + (** @canonical Odoc_model.Paths.Identifier.UnboxedFieldParent.t *) + type label_parent_pv = [ field_parent_pv | page_pv | class_signature_pv ] (** @canonical Odoc_model.Paths.Identifier.LabelParent.t_pv *) @@ -149,6 +155,12 @@ module Identifier = struct and field = field_pv id (** @canonical Odoc_model.Paths.Identifier.Field.t *) + type unboxed_field_pv = [ `UnboxedField of unboxed_field_parent * UnboxedFieldName.t ] + (** @canonical Odoc_model.Paths.Identifier.UnboxedField.t_pv *) + + and unboxed_field = unboxed_field_pv id + (** @canonical Odoc_model.Paths.Identifier.UnboxedField.t *) + type extension_pv = [ `Extension of signature * ExtensionName.t ] (** @canonical Odoc_model.Paths.Identifier.Extension.t_pv *) @@ -210,6 +222,7 @@ module Identifier = struct | class_signature_pv | datatype_pv | field_parent_pv + | unboxed_field_parent_pv | label_parent_pv | module_pv | functor_parameter_pv @@ -218,6 +231,7 @@ module Identifier = struct | type_pv | constructor_pv | field_pv + | unboxed_field_pv | extension_pv | extension_decl_pv | exception_pv @@ -287,6 +301,8 @@ module Identifier = struct type reference_field = field + type reference_unboxed_field = unboxed_field + type reference_extension = [ extension_pv | exception_pv ] id type reference_extension_decl = extension_decl @@ -526,6 +542,8 @@ module rec Reference : sig type tag_only_field = [ `TField ] + type tag_only_unboxed_field = [ `TUnboxedField ] + type tag_only_extension = [ `TExtension ] type tag_only_exception = [ `TException ] @@ -562,6 +580,7 @@ module rec Reference : sig | `TType | `TConstructor | `TField + | `TUnboxedField | `TExtension | `TExtensionDecl | `TException @@ -692,6 +711,13 @@ module rec Reference : sig | `Field of fragment_type_parent * FieldName.t ] (** @canonical Odoc_model.Paths.Reference.Field.t *) + type unboxed_field = + [ `Resolved of Resolved_reference.unboxed_field + | `Root of string * [ `TField | `TUnknown ] + | `Dot of label_parent * string + | `UnboxedField of fragment_type_parent * UnboxedFieldName.t ] + (** @canonical Odoc_model.Paths.Reference.UnboxedField.t *) + type extension = [ `Resolved of Resolved_reference.extension | `Root of string * [ `TExtension | `TException | `TUnknown ] @@ -776,6 +802,7 @@ module rec Reference : sig | `Type of signature * TypeName.t | `Constructor of fragment_type_parent * ConstructorName.t | `Field of fragment_type_parent * FieldName.t + | `UnboxedField of fragment_type_parent * UnboxedFieldName.t | `Extension of signature * ExtensionName.t | `ExtensionDecl of signature * ExtensionName.t | `Exception of signature * ExceptionName.t @@ -836,6 +863,11 @@ and Resolved_reference : sig | `Type of signature * TypeName.t ] (** @canonical Odoc_model.Paths.Reference.Resolved.FragmentTypeParent.t *) + and unboxed_field_parent = + [ `Identifier of Identifier.unboxed_field_parent + | `Type of signature * TypeName.t ] + (** @canonical Odoc_model.Paths.Reference.Resolved.FragmentTypeParent.t *) + (* The only difference between parent and label_parent is that the Identifier allows more types *) and label_parent = @@ -875,6 +907,11 @@ and Resolved_reference : sig | `Field of field_parent * FieldName.t ] (** @canonical Odoc_model.Paths.Reference.Resolved.Field.t *) + type unboxed_field = + [ `Identifier of Identifier.reference_unboxed_field + | `UnboxedField of unboxed_field_parent * UnboxedFieldName.t ] + (** @canonical Odoc_model.Paths.Reference.Resolved.UnboxedField.t *) + type extension = [ `Identifier of Identifier.reference_extension | `Extension of signature * ExtensionName.t @@ -944,6 +981,7 @@ and Resolved_reference : sig | `Constructor of datatype * ConstructorName.t | `PolyConstructor of datatype * ConstructorName.t | `Field of field_parent * FieldName.t + | `UnboxedField of unboxed_field_parent * UnboxedFieldName.t | `Extension of signature * ExtensionName.t | `ExtensionDecl of signature * ExtensionName.t * ExtensionName.t | `Exception of signature * ExceptionName.t diff --git a/src/model/reference.ml b/src/model/reference.ml index bd162fee4a..68d24252f4 100644 --- a/src/model/reference.ml +++ b/src/model/reference.ml @@ -479,6 +479,8 @@ let parse whole_reference_location s : (parent next_token tokens, ConstructorName.make_std identifier) | `TField -> `Field (parent next_token tokens, FieldName.make_std identifier) + | `TUnboxedField -> + `UnboxedField (parent next_token tokens, UnboxedFieldName.make_std identifier) | `TExtension -> `Extension (signature next_token tokens, ExtensionName.make_std identifier) diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 3b276a8783..53cf227182 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -325,6 +325,16 @@ and typedecl_field = F ("type_", (fun t -> t.type_), typeexpr_t); ] +and typedecl_unboxed_field = + let open Lang.TypeDecl.UnboxedField in + Unboxed_record + [ + UF ("id", (fun t -> t.id), identifier); + UF ("doc", (fun t -> t.doc), docs); + UF ("mutable_", (fun t -> t.mutable_), bool); + UF ("type_", (fun t -> t.type_), typeexpr_t); + ] + and typedecl_constructor_argument = let open Lang.TypeDecl.Constructor in T.Variant @@ -348,6 +358,7 @@ and typedecl_representation = (function | Variant x -> C ("Variant", x, List typedecl_constructor) | Record x -> C ("Record", x, List typedecl_field) + | Record_unboxed_product x -> C ("Record_unboxed_product", x, List typedecl_unboxed_field) | Extensible -> C0 "Extensible") and typedecl_variance = @@ -646,6 +657,7 @@ and typeexpr_t = (x1, x2, x3), Triple (Option typeexpr_label, typeexpr_t, typeexpr_t) ) | Tuple x -> C ("Tuple", x, List (Pair (Option string, typeexpr_t))) + | Unboxed_tuple x -> C ("Unboxed_tuple", x, List (Pair (Option string, typeexpr_t))) | Constr (x1, x2) -> C ("Constr", ((x1 :> Paths.Path.t), x2), Pair (path, List typeexpr_t)) | Polymorphic_variant x -> diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index c3c4792a6d..90c8e5a532 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -22,6 +22,8 @@ module Names = struct let fieldname = To_string FieldName.to_string + let unboxedfieldname = To_string UnboxedFieldName.to_string + let exceptionname = To_string ExceptionName.to_string let extensionname = To_string ExtensionName.to_string @@ -129,6 +131,11 @@ module General_paths = struct ( "`Field", ((parent :> id_t), name), Pair (identifier, Names.fieldname) ) + | `UnboxedField (parent, name) -> + C + ( "`UnboxedField", + ((parent :> id_t), name), + Pair (identifier, Names.unboxedfieldname) ) | `Extension (parent, name) -> C ( "`Extension", @@ -192,6 +199,7 @@ module General_paths = struct | `TExtension -> C0 "`TExtension" | `TExtensionDecl -> C0 "`TExtensionDecl" | `TField -> C0 "`TField" + | `TUnboxedField -> C0 "`TUnboxedField" | `TInstanceVariable -> C0 "`TInstanceVariable" | `TLabel -> C0 "`TLabel" | `TMethod -> C0 "`TMethod" @@ -329,6 +337,8 @@ module General_paths = struct Pair (reference, Names.constructorname) ) | `Field (x1, x2) -> C ("`Field", ((x1 :> r), x2), Pair (reference, Names.fieldname)) + | `UnboxedField (x1, x2) -> + C ("`UnboxedField", ((x1 :> r), x2), Pair (reference, Names.unboxedfieldname)) | `Extension (x1, x2) -> C ( "`Extension", @@ -408,6 +418,11 @@ module General_paths = struct ( "`Field", ((x1 :> rr), x2), Pair (resolved_reference, Names.fieldname) ) + | `UnboxedField (x1, x2) -> + C + ( "`UnboxedField", + ((x1 :> rr), x2), + Pair (resolved_reference, Names.unboxedfieldname) ) | `Hidden x -> C ("`Hidden", (x :> rr), resolved_reference) | `Identifier x -> C ("`Identifier", (x :> id_t), identifier) | `InstanceVariable (x1, x2) -> diff --git a/src/model_desc/type_desc.ml b/src/model_desc/type_desc.ml index a6d963c594..2c65620d8f 100644 --- a/src/model_desc/type_desc.ml +++ b/src/model_desc/type_desc.ml @@ -3,6 +3,7 @@ deserialize. *) type 'a t = | Record : 'a field list -> 'a t + | Unboxed_record : 'a unboxed_field list -> 'a t | Variant : ('a -> case) -> 'a t | Pair : 'a t * 'b t -> ('a * 'b) t | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t @@ -13,6 +14,8 @@ type 'a t = and 'a field = F : string * ('a -> 'b) * 'b t -> 'a field +and 'a unboxed_field = UF : string * ('a -> 'b) * 'b t -> 'a unboxed_field + and case = C : string * 'b * 'b t -> case | C0 : string -> case let bool : bool t = To_string string_of_bool diff --git a/src/occurrences/table.ml b/src/occurrences/table.ml index 88fd0e3fbf..3ed98bfc20 100644 --- a/src/occurrences/table.ml +++ b/src/occurrences/table.ml @@ -38,6 +38,7 @@ let add ?(quantity = 1) tbl id = | `ModuleType (parent, _) -> do_ parent | `Method (parent, _) -> do_ parent | `Field (parent, _) -> do_ parent + | `UnboxedField (parent, _) -> do_ parent | `Extension (parent, _) -> do_ parent | `Type (parent, _) -> do_ parent | `Constructor (parent, _) -> do_ parent @@ -68,6 +69,7 @@ let rec get t id = | `ModuleType (parent, _) -> do_ parent | `Method (parent, _) -> do_ parent | `Field (parent, _) -> do_ parent + | `UnboxedField (parent, _) -> do_ parent | `Extension (parent, _) -> do_ parent | `ExtensionDecl (parent, _, _) -> do_ parent | `Type (parent, _) -> do_ parent @@ -121,6 +123,12 @@ module Strip = struct | { iv = #DataType.t_pv; _ } as v -> (strip_datatype_path v :> FieldParent.t) + and strip_unboxed_field_parent_path : UnboxedFieldParent.t -> UnboxedFieldParent.t = + fun x -> + match x with + | { iv = #DataType.t_pv; _ } as v -> + (strip_datatype_path v :> UnboxedFieldParent.t) + and strip_label_parent_path : LabelParent.t -> LabelParent.t = fun x -> match x with @@ -141,6 +149,8 @@ module Strip = struct Mk.instance_variable (strip_class_sig_path p, name) | { iv = `Method (p, name); _ } -> Mk.method_ (strip_class_sig_path p, name) | { iv = `Field (p, name); _ } -> Mk.field (strip_field_parent_path p, name) + | { iv = `UnboxedField (p, name); _ } -> + Mk.unboxed_field (strip_unboxed_field_parent_path p, name) | { iv = `Label (p, name); _ } -> Mk.label (strip_label_parent_path p, name) | { iv = `Exception (p, name); _ } -> Mk.exception_ (strip_sig_path p, name) | { iv = `Extension (p, name); _ } -> Mk.extension (strip_sig_path p, name) diff --git a/src/search/html.ml b/src/search/html.ml index f46819f8b3..d1ddf9748d 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -104,6 +104,7 @@ let typedecl_repr ~private_ (repr : TypeDecl.Representation.t) = constructor ~id ~args ~res) |> String.concat " | " | Record record -> Text.of_record record + | Record_unboxed_product record -> Text.of_unboxed_record record let typedecl_rhs ({ equation; representation; _ } : Entry.type_decl_entry) = let ({ private_; manifest; constraints; _ } : TypeDecl.Equation.t) = @@ -155,6 +156,8 @@ let kind_constructor = "cons" let kind_field = "field" +let kind_unboxed_field = "unboxed field" + let kind_value = "val" let kind_extension = "ext" @@ -164,6 +167,7 @@ let string_of_kind = function | Constructor _ -> kind_constructor | Field _ -> kind_field + | UnboxedField _ -> kind_unboxed_field | ExtensionConstructor _ -> kind_extension_constructor | TypeDecl _ -> kind_typedecl | Module _ -> kind_module @@ -194,6 +198,7 @@ let rhs_of_kind (entry : Entry.kind) = | Constructor t | ExtensionConstructor t | Exception t -> Some (constructor_rhs t) | Field f -> Some (field_rhs f) + | UnboxedField f -> Some (field_rhs f) | Module _ | Class_type _ | Method _ | Class _ | TypeExtension _ | ModuleType _ | Doc | Page _ | Impl | Dir -> None diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index 4299ab522f..0eca41bea3 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -55,6 +55,8 @@ let rec of_id x = ret "Constructor" (ConstructorName.to_string name) :: of_id (parent :> t) | `Field (parent, name) -> ret "Field" (FieldName.to_string name) :: of_id (parent :> t) + | `UnboxedField (parent, name) -> + ret "UnboxedField" (UnboxedFieldName.to_string name) :: of_id (parent :> t) | `Extension (parent, name) -> ret "Extension" (ExtensionName.to_string name) :: of_id (parent :> t) | `ExtensionDecl (parent, _, name) -> @@ -107,6 +109,8 @@ let rec prefix_name_kind_of_id (n : Odoc_model.Paths.Identifier.t) = (prefix_of_parent parent, ConstructorName.to_string name, "constructor") | `Field (parent, name) -> (prefix_of_parent parent, FieldName.to_string name, "field") + | `UnboxedField (parent, name) -> + (prefix_of_parent parent, UnboxedFieldName.to_string name, "unboxed_field") | `Extension (parent, name) -> (prefix_of_parent parent, ExtensionName.to_string name, "extension") | `ExtensionDecl (parent, _, name) -> @@ -211,6 +215,13 @@ let of_entry ({ Entry.id; doc; kind ; source_loc = _} as entry) html occurrences ("type", `String (Text.of_type type_)); ("parent_type", `String (Text.of_type parent_type)); ] + | UnboxedField { mutable_; type_; parent_type } -> + return "UnboxedField" + [ + ("mutable", `Bool mutable_); + ("type", `String (Text.of_type type_)); + ("parent_type", `String (Text.of_type parent_type)); + ] | Page _ -> return "Page" [] | Impl -> return "Impl" [] | Dir -> return "Dir" [] diff --git a/src/search/text.ml b/src/search/text.ml index 3ef043edfb..da112c39e7 100644 --- a/src/search/text.ml +++ b/src/search/text.ml @@ -97,3 +97,7 @@ let of_doc doc = Of_comments.string_of_doc doc let of_record fields = let te_text = Odoc_document.ML.record fields in Of_document.documented_src te_text + +let of_unboxed_record fields = + let te_text = Odoc_document.ML.unboxed_record fields in + Of_document.documented_src te_text diff --git a/src/search/text.mli b/src/search/text.mli index 0bedba25b4..afaf588d63 100644 --- a/src/search/text.mli +++ b/src/search/text.mli @@ -7,3 +7,5 @@ val of_type : Odoc_model.Lang.TypeExpr.t -> string val of_doc : Odoc_model.Comment.elements -> string val of_record : Odoc_model.Lang.TypeDecl.Field.t list -> string + +val of_unboxed_record : Odoc_model.Lang.TypeDecl.UnboxedField.t list -> string diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index cde6e8c49b..aa5042bea3 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -783,12 +783,18 @@ and type_decl_representation : match r with | Variant cs -> Variant (List.map (type_decl_constructor env parent) cs) | Record fs -> Record (List.map (type_decl_field env parent) fs) + | Record_unboxed_product fs -> + Record_unboxed_product (List.map (type_decl_unboxed_field env parent) fs) | Extensible -> Extensible and type_decl_field env parent f = let open TypeDecl.Field in { f with type_ = type_expression env parent f.type_ } +and type_decl_unboxed_field env parent f = + let open TypeDecl.UnboxedField in + { f with type_ = type_expression env parent f.type_ } + and type_decl_constructor_argument env parent c = let open TypeDecl.Constructor in match c with @@ -914,6 +920,8 @@ and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ = | Tuple ts -> Tuple (List.map (fun (lbl, ty) -> (lbl, type_expression env parent ty)) ts) + | Unboxed_tuple ts -> + Unboxed_tuple (List.map (fun (l, t) -> l, type_expression env parent t) ts) | Constr (path, ts') -> ( let cp = Component.Of_Lang.(type_path (empty ()) path) in let ts = List.map (type_expression env parent) ts' in diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 9625d1201d..f81c03d491 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -124,6 +124,7 @@ and TypeExpr : sig | Alias of t * string | Arrow of label option * t * t | Tuple of (string option * t) list + | Unboxed_tuple of (string option * t) list | Constr of Cpath.type_ * t list | Polymorphic_variant of TypeExpr.Polymorphic_variant.t | Object of TypeExpr.Object.t @@ -250,6 +251,15 @@ and TypeDecl : sig } end + module UnboxedField : sig + type t = { + name : string; + doc : CComment.docs; + mutable_ : bool; + type_ : TypeExpr.t; + } + end + module Constructor : sig type argument = Tuple of TypeExpr.t list | Record of Field.t list @@ -265,6 +275,7 @@ and TypeDecl : sig type t = | Variant of Constructor.t list | Record of Field.t list + | Record_unboxed_product of UnboxedField.t list | Extensible end @@ -526,6 +537,9 @@ module Element = struct type field = [ `Field of Identifier.Field.t * TypeDecl.Field.t ] + type unboxed_field = + [ `UnboxedField of Identifier.UnboxedField.t * TypeDecl.UnboxedField.t ] + (* No component for pages yet *) type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ] @@ -545,6 +559,7 @@ module Element = struct | extension | extension_decl | field + | unboxed_field | page ] let identifier : [< any ] -> Odoc_model.Paths.Identifier.t = @@ -560,6 +575,7 @@ module Element = struct | `Constructor (id, _) -> (id :> t) | `Exception (id, _) -> (id :> t) | `Field (id, _) -> (id :> t) + | `UnboxedField (id, _) -> (id :> t) | `Extension (id, _, _) -> (id :> t) | `ExtensionDecl (id, _) -> (id :> t) | `Page (id, _) -> (id :> t) @@ -713,6 +729,10 @@ module Fmt = struct Format.fprintf ppf "%a.%s" (model_identifier c) (ty :> id) (FieldName.to_string name) + | `UnboxedField (ty, name) -> + Format.fprintf ppf "%a.%s" (model_identifier c) + (ty :> id) + (UnboxedFieldName.to_string name) | `Exception (p, name) -> Format.fprintf ppf "%a.%s" (model_identifier c) (p :> id) @@ -1017,6 +1037,7 @@ module Fmt = struct function | Variant cs -> fpp_list " | " "%a" (type_decl_constructor c) ppf cs | Record fs -> type_decl_fields c ppf fs + | Record_unboxed_product fs -> type_decl_unboxed_fields c ppf fs | Extensible -> Format.fprintf ppf ".." and type_decl_constructor c ppf t = @@ -1039,8 +1060,16 @@ module Fmt = struct let mutable_ = if t.mutable_ then "mutable " else "" in fpf ppf "%s%s : %a" mutable_ t.name (type_expr c) t.type_ + and type_decl_unboxed_field c ppf t = + let open TypeDecl.UnboxedField in + let mutable_ = if t.mutable_ then "mutable " else "" in + fpf ppf "%s%s : %a" mutable_ t.name (type_expr c) t.type_ + and type_decl_fields c ppf fs = - fpp_list "; " "{ %a }" (type_decl_field c) ppf fs + fpf ppf "{ %a }" (fpp_list "; " "%a" (type_decl_field c)) fs + + and type_decl_unboxed_fields c ppf fs = + fpf ppf "#{ %a }" (fpp_list "; " "%a" (type_decl_unboxed_field c)) fs and type_constructor_params c ppf ts = fpp_list " * " "%a" (type_expr c) ppf ts @@ -1160,6 +1189,7 @@ module Fmt = struct Format.fprintf ppf "%a(%a) -> %a" type_expr_label l (type_expr c) t1 (type_expr c) t2 | Tuple ts -> Format.fprintf ppf "(%a)" (type_labeled_tuple c) ts + | Unboxed_tuple ts -> Format.fprintf ppf "#(%a)" (type_labeled_tuple c) ts | Constr (p, args) -> ( match args with | [] -> Format.fprintf ppf "%a" (type_path c) p @@ -1639,6 +1669,11 @@ module Fmt = struct (model_resolved_reference c) (parent :> t) (FieldName.to_string name) + | `UnboxedField (parent, name) -> + Format.fprintf ppf "%a.#%s" + (model_resolved_reference c) + (parent :> t) + (UnboxedFieldName.to_string name) | `Extension (parent, name) -> Format.fprintf ppf "%a.%s" (model_resolved_reference c) @@ -1735,6 +1770,10 @@ module Fmt = struct Format.fprintf ppf "%a.%s" (model_reference c) (parent :> t) (FieldName.to_string name) + | `UnboxedField (parent, name) -> + Format.fprintf ppf "%a.%s" (model_reference c) + (parent :> t) + (UnboxedFieldName.to_string name) | `Extension (parent, name) -> Format.fprintf ppf "%a.%s" (model_reference c) (parent :> t) @@ -2185,6 +2224,8 @@ module Of_Lang = struct TypeDecl.Representation.Variant (List.map (type_decl_constructor ident_map) cs) | Record fs -> Record (List.map (type_decl_field ident_map) fs) + | Record_unboxed_product fs -> + Record_unboxed_product (List.map (type_decl_unboxed_field ident_map) fs) | Extensible -> Extensible and type_decl_constructor ident_map t = @@ -2215,6 +2256,15 @@ module Of_Lang = struct type_; } + and type_decl_unboxed_field ident_map f = + let type_ = type_expression ident_map f.type_ in + { + TypeDecl.UnboxedField.name = Paths.Identifier.name f.id; + doc = docs ident_map f.doc; + mutable_ = f.mutable_; + type_; + } + and type_equation ident_map teq = let open Odoc_model.Lang.TypeDecl.Equation in { @@ -2286,6 +2336,8 @@ module Of_Lang = struct | Tuple ts -> Tuple (List.map (fun (lbl, ty) -> (lbl, type_expression ident_map ty)) ts) + | Unboxed_tuple ts -> + Unboxed_tuple (List.map (fun (l, t) -> l, type_expression ident_map t) ts) | Polymorphic_variant v -> Polymorphic_variant (type_expr_polyvar ident_map v) | Poly (s, ts) -> Poly (s, type_expression ident_map ts) diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 62c4287931..1b87f376a1 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -119,6 +119,7 @@ and TypeExpr : sig | Alias of t * string | Arrow of label option * t * t | Tuple of (string option * t) list + | Unboxed_tuple of (string option * t) list | Constr of Cpath.type_ * t list | Polymorphic_variant of TypeExpr.Polymorphic_variant.t | Object of TypeExpr.Object.t @@ -240,6 +241,15 @@ and TypeDecl : sig } end + module UnboxedField : sig + type t = { + name : string; + doc : CComment.docs; + mutable_ : bool; + type_ : TypeExpr.t; + } + end + module Constructor : sig type argument = Tuple of TypeExpr.t list | Record of Field.t list @@ -255,6 +265,7 @@ and TypeDecl : sig type t = | Variant of Constructor.t list | Record of Field.t list + | Record_unboxed_product of UnboxedField.t list | Extensible end @@ -502,6 +513,9 @@ module Element : sig type field = [ `Field of Identifier.Field.t * TypeDecl.Field.t ] + type unboxed_field = + [ `UnboxedField of Identifier.UnboxedField.t * TypeDecl.UnboxedField.t ] + (* No component for pages yet *) type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ] @@ -521,6 +535,7 @@ module Element : sig | extension | extension_decl | field + | unboxed_field | page ] val identifier : [< any ] -> Identifier.t diff --git a/src/xref2/env.ml b/src/xref2/env.ml index da9e7889f5..1c25956c07 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -91,6 +91,7 @@ type kind = | Kind_Exception | Kind_Extension | Kind_Field + | Kind_UnboxedField module ElementsByName : sig type t @@ -167,6 +168,7 @@ type t = { ids : ElementsById.t; (** Elements mapped by their identifier. Queried with {!find_by_id}. *) ambiguous_labels : Component.Element.label amb_err Identifier.Maps.Label.t; + ambiguous_unboxed_labels : Component.Element.label amb_err Identifier.Maps.Label.t; resolver : resolver option; recorder : recorder option; warnings_tags : string list; @@ -212,6 +214,7 @@ let empty = resolver = None; recorder = None; ambiguous_labels = Identifier.Maps.Label.empty; + ambiguous_unboxed_labels = Identifier.Maps.Label.empty; warnings_tags = []; fragmentroot = None; } @@ -242,8 +245,10 @@ let add_to_elts kind identifier component env = ids = ElementsById.add identifier component env.ids; } -let add_label identifier heading env = +let add_label identifier heading env ~unboxed = assert env.linking; + (* TODO: implement proper behavior for unboxed labels *) + assert (not unboxed); let comp = `Label (identifier, heading) in let name = Identifier.name identifier in let ambiguous_labels = @@ -279,7 +284,7 @@ let add_docs (docs : Comment.docs) env = (fun env -> function | { Location_.value = `Heading (attrs, id, text); location } -> let label = Ident.Of_Identifier.label id in - add_label id { Component.Label.attrs; label; text; location } env + add_label id { Component.Label.attrs; label; text; location } env ~unboxed:false | _ -> env) env docs.elements @@ -295,7 +300,7 @@ let add_cdocs p (docs : Component.CComment.docs) env = let label = Paths.Identifier.Mk.label (Paths.Identifier.label_parent p, name) in - add_label label h env + add_label label h env ~unboxed:false | _ -> env) env docs.elements @@ -320,6 +325,13 @@ let add_type (identifier : Identifier.Type.t) t env = FieldName.make_std field.name ) in add_to_elts Kind_Field ident (`Field (ident, field)) env + and add_unboxed_field env (field : TypeDecl.UnboxedField.t) = + let ident = + Paths.Identifier.Mk.unboxed_field + ( (identifier :> Paths.Identifier.UnboxedFieldParent.t), + UnboxedFieldName.make_std field.name ) + in + add_to_elts Kind_UnboxedField ident (`UnboxedField (ident, field)) env in let open TypeDecl in match t.representation with @@ -329,6 +341,9 @@ let add_type (identifier : Identifier.Type.t) t env = | Some (Record fields) -> ( List.fold_left add_field cs fields, List.map (fun t -> t.Field.doc) fields ) + | Some (Record_unboxed_product fields) -> + ( List.fold_left add_unboxed_field cs fields, + List.map (fun t -> t.UnboxedField.doc) fields ) | Some Extensible | None -> (cs, []) in let env, docs = if env.linking then open_typedecl env else (env, []) in @@ -627,6 +642,9 @@ let s_extension : Component.Element.extension scope = let s_field : Component.Element.field scope = make_scope (function #Component.Element.field as r -> Some r | _ -> None) +let s_unboxed_field : Component.Element.unboxed_field scope = + make_scope (function #Component.Element.unboxed_field as r -> Some r | _ -> None) + let s_label_parent : Component.Element.label_parent scope = make_scope ~root:lookup_page_or_root_module_fallback (function | #Component.Element.label_parent as r -> Some r diff --git a/src/xref2/env.mli b/src/xref2/env.mli index fdb1b36bd7..f6651e6961 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -64,7 +64,7 @@ val add_module_type : val add_value : Identifier.Value.t -> Component.Value.t -> t -> t -val add_label : Identifier.Label.t -> Component.Label.t -> t -> t +val add_label : Identifier.Label.t -> Component.Label.t -> t -> unboxed:bool -> t val add_class : Identifier.Class.t -> Component.Class.t -> t -> t @@ -154,6 +154,8 @@ val s_extension : Component.Element.extension scope val s_field : Component.Element.field scope +val s_unboxed_field : Component.Element.unboxed_field scope + val s_label_parent : Component.Element.label_parent scope val s_fragment_type_parent : Component.Element.fragment_type_parent scope diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 9cebe4ee75..4cdad2ec9f 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -16,6 +16,7 @@ module Tools_error = struct | `Page | `Cons | `Field + | `UnboxedField | `Label | `Page_path | `Module_path @@ -129,6 +130,7 @@ module Tools_error = struct | `Page -> "page" | `Cons -> "constructor" | `Field -> "field" + | `UnboxedField -> "unboxed field" | `Label -> "label" | `Page_path -> "path to a page" | `Module_path -> "path to a module" diff --git a/src/xref2/expand_tools.ml b/src/xref2/expand_tools.ml index a14d6f1218..5b9a0942f5 100644 --- a/src/xref2/expand_tools.ml +++ b/src/xref2/expand_tools.ml @@ -58,6 +58,7 @@ let rec type_expr map t = if List.mem_assoc s map then raise Clash else Alias (type_expr map t, s) | Arrow (l, t1, t2) -> Arrow (l, type_expr map t1, type_expr map t2) | Tuple ts -> Tuple (List.map (fun (l, ty) -> (l, type_expr map ty)) ts) + | Unboxed_tuple ts -> Unboxed_tuple (List.map (fun (l, t) -> l, type_expr map t) ts) | Constr (p, ts) -> Constr (p, List.map (type_expr map) ts) | Polymorphic_variant pv -> Polymorphic_variant (polymorphic_variant map pv) | Object o -> Object (object_ map o) diff --git a/src/xref2/find.ml b/src/xref2/find.ml index 92ad35fb18..e73fd96ffe 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -38,7 +38,9 @@ type polymorphic_constructor = type field = [ `FField of TypeDecl.Field.t ] -type any_in_type = [ constructor | field | polymorphic_constructor ] +type unboxed_field = [ `FUnboxedField of TypeDecl.UnboxedField.t ] + +type any_in_type = [ constructor | field | unboxed_field | polymorphic_constructor ] type any_in_type_in_sig = [ `In_type of Odoc_model.Names.TypeName.t * TypeDecl.t * any_in_type ] @@ -206,6 +208,12 @@ let any_in_type (typ : TypeDecl.t) name = | _ :: tl -> find_field tl | [] -> None in + let rec find_unboxed_field = function + | ({ TypeDecl.UnboxedField.name = name'; _ } as field) :: _ when name' = name -> + Some (`FUnboxedField field) + | _ :: tl -> find_unboxed_field tl + | [] -> None + in let rec find_poly = function | TypeExpr.Polymorphic_variant.Constructor ({ TypeExpr.Polymorphic_variant.Constructor.name = name'; _ } as cons) @@ -218,6 +226,7 @@ let any_in_type (typ : TypeDecl.t) name = match typ.representation with | Some (Variant cons) -> find_cons cons | Some (Record fields) -> find_field fields + | Some (Record_unboxed_product fields) -> find_unboxed_field fields | Some Extensible -> None | None -> ( match typ.equation.manifest with diff --git a/src/xref2/find.mli b/src/xref2/find.mli index 4016e24478..b87ed5f1e3 100644 --- a/src/xref2/find.mli +++ b/src/xref2/find.mli @@ -37,7 +37,9 @@ type polymorphic_constructor = type field = [ `FField of TypeDecl.Field.t ] -type any_in_type = [ constructor | field | polymorphic_constructor ] +type unboxed_field = [ `FUnboxedField of TypeDecl.UnboxedField.t ] + +type any_in_type = [ constructor | field | unboxed_field | polymorphic_constructor ] type any_in_type_in_sig = [ `In_type of TypeName.t * TypeDecl.t * any_in_type ] diff --git a/src/xref2/ident.ml b/src/xref2/ident.ml index f9a2e6af4b..a6ff7df042 100644 --- a/src/xref2/ident.ml +++ b/src/xref2/ident.ml @@ -14,6 +14,8 @@ type constructor = [ `LConstructor of ConstructorName.t * int ] type field = [ `LField of FieldName.t * int ] +type unboxed_field = [ `LUnboxedField of UnboxedFieldName.t * int ] + type extension = [ `LExtension of ExtensionName.t * int ] type exception_ = [ `LException of ExceptionName.t * int ] @@ -34,6 +36,7 @@ type any = | type_ | constructor | field + | unboxed_field | extension | exception_ | value @@ -56,6 +59,7 @@ let int_of_any : any -> int = function | `LValue (_, i) | `LInstanceVariable (_, i) | `LField (_, i) + | `LUnboxedField (_, i) | `LLabel (_, i) | `LModuleType (_, i) | `LPage (_, i) @@ -193,6 +197,7 @@ let fmt_aux (id : any) : string * int = | `LType (n, i) -> (TypeName.to_string n, i) | `LConstructor (n, i) -> (ConstructorName.to_string n, i) | `LField (n, i) -> (FieldName.to_string n, i) + | `LUnboxedField (n, i) -> (UnboxedFieldName.to_string n, i) | `LExtension (n, i) -> (ExtensionName.to_string n, i) | `LException (n, i) -> (ExceptionName.to_string n, i) | `LValue (n, i) -> (ValueName.to_string n, i) diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 5d8a517166..86845805d3 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -929,6 +929,20 @@ and type_decl_field : type_ = type_expr map (parent :> Identifier.LabelParent.t) f.type_; } +and type_decl_unboxed_field : + maps -> + Identifier.UnboxedFieldParent.t -> + Component.TypeDecl.UnboxedField.t -> + Odoc_model.Lang.TypeDecl.UnboxedField.t = + fun map parent f -> + let identifier = Identifier.Mk.unboxed_field (parent, UnboxedFieldName.make_std f.name) in + { + id = identifier; + doc = docs (parent :> Identifier.LabelParent.t) f.doc; + mutable_ = f.mutable_; + type_ = type_expr map (parent :> Identifier.LabelParent.t) f.type_; + } + and type_decl_equation map (parent : Identifier.FieldParent.t) (eqn : Component.TypeDecl.Equation.t) : Odoc_model.Lang.TypeDecl.Equation.t = @@ -969,6 +983,12 @@ and type_decl_representation map id (t : Component.TypeDecl.Representation.t) : (type_decl_field map (id :> Odoc_model.Paths.Identifier.FieldParent.t)) fs) + | Record_unboxed_product fs -> + Record_unboxed_product + (List.map + (type_decl_unboxed_field map + (id :> Odoc_model.Paths.Identifier.UnboxedFieldParent.t)) + fs) and type_decl_constructor : maps -> @@ -1010,6 +1030,8 @@ and type_expr map (parent : Identifier.LabelParent.t) (t : Component.TypeExpr.t) Arrow (lbl, type_expr map parent t1, type_expr map parent t2) | Tuple ts -> Tuple (List.map (fun (lbl, ty) -> (lbl, type_expr map parent ty)) ts) + | Unboxed_tuple ts -> + Unboxed_tuple (List.map (fun (l, t) -> l, type_expr map parent t) ts) | Constr (path, ts) -> Constr ( (Path.type_ map path :> Paths.Path.Type.t), diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 08431dea7e..778972e861 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -462,6 +462,11 @@ let warn_on_hidden_representation (id : Id.Type.t) internal_typ_exp t.type_ in + let internal_unboxed_field t = + let open Lang.TypeDecl.UnboxedField in + internal_typ_exp t.type_ + in + let fmt_cfg = Component.Fmt.{ default with short_paths = true } in match r with | Variant constructors -> @@ -474,6 +479,11 @@ let warn_on_hidden_representation (id : Id.Type.t) Lookup_failures.report_warning "@[<2>Hidden fields in type '%a'@]" Component.Fmt.(model_identifier fmt_cfg) (id :> Id.any) + | Record_unboxed_product fields -> + if List.exists internal_unboxed_field fields then + Lookup_failures.report_warning "@[<2>Hidden unboxed fields in type '%a'@]" + Component.Fmt.(model_identifier fmt_cfg) + (id :> Id.any) | Extensible -> () let rec unit env t = @@ -979,6 +989,8 @@ and type_decl_representation : match r with | Variant cs -> Variant (List.map (type_decl_constructor env parent) cs) | Record fs -> Record (List.map (type_decl_field env parent) fs) + | Record_unboxed_product fs -> + Record_unboxed_product (List.map (type_decl_unboxed_field env parent) fs) | Extensible -> Extensible and type_decl : Env.t -> Id.Signature.t -> TypeDecl.t -> TypeDecl.t = @@ -1041,6 +1053,11 @@ and type_decl_field env parent f = let doc = comment_docs env parent f.doc in { f with type_ = type_expression env parent [] f.type_; doc } +and type_decl_unboxed_field env parent f = + let open TypeDecl.UnboxedField in + let doc = comment_docs env parent f.doc in + { f with type_ = type_expression env parent [] f.type_; doc } + and type_decl_constructor_argument env parent c = let open TypeDecl.Constructor in match c with @@ -1120,6 +1137,8 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ = (List.map (fun (lbl, ty) -> (lbl, type_expression env parent visited ty)) ts) + | Unboxed_tuple ts -> + Unboxed_tuple (List.map (fun (l, t) -> l, type_expression env parent visited t) ts) | Constr (path', ts') -> ( let path = type_path env path' in let ts = List.map (type_expression env parent visited) ts' in diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 7fae1614e6..ffd28fa01e 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -78,6 +78,7 @@ let ref_kind_of_element = function | `Extension _ -> "extension" | `ExtensionDecl _ -> "extension-decl" | `Field _ -> "field" + | `UnboxedField _ -> "unboxed-field" | `Page _ -> "page" let ref_kind_of_find = function @@ -94,6 +95,7 @@ let ref_kind_of_find = function | `FExt _ -> "extension" | `FExtDecl _ -> "extension-decl" | `FField _ | `In_type (_, _, `FField _) -> "field" + | `FUnboxedField _ | `In_type (_, _, `FUnboxedField _) -> "unboxed-field" | `FMethod _ -> "method" | `FInstance_variable _ -> "instance-variable" @@ -519,8 +521,8 @@ module CS = struct env_lookup_by_name Env.s_constructor name env >>= fun (`Constructor (id, _)) -> Ok (`Identifier id :> t) - let got_a_field name = - (* Let's pretend we didn't see the field and say we didn't find anything. *) + let not_a_constructor name = + (* Let's pretend we didn't see the field/unboxed field and say we didn't find anything. *) Error (`Find_by_name (`Cons, name)) let in_parent _env (parent : fragment_type_parent_lookup_result) name = @@ -528,8 +530,15 @@ module CS = struct match parent with | `S (parent', parent_cp, sg) -> ( let sg = Tools.prefix_signature (parent_cp, sg) in - find_ambiguous Find.any_in_type_in_sig sg name_s >>= function - | `In_type (_, _, `FField _) -> got_a_field name_s + let find_ambiguous = + (find_ambiguous : ?kind:([> `Any ] as 'a) -> + (Component.Signature.t -> string -> Find.any_in_type_in_sig list) + -> + Component.Signature.t -> string -> (Find.any_in_type_in_sig, [> `Find_by_name of 'a * string ]) result) + in + find_ambiguous Find.any_in_type_in_sig sg name_s >>= function + | `In_type (_, _, `FField _) -> not_a_constructor name_s + | `In_type (_, _, `FUnboxedField _) -> not_a_constructor name_s | `In_type (typ_name, _, `FPoly cs) -> Ok (`PolyConstructor @@ -538,7 +547,8 @@ module CS = struct Ok (`Constructor (`Type (parent', typ_name), name))) | `T (parent', t) -> ( find Find.any_in_type t (fun x -> x) name_s >>= function - | `FField _ -> got_a_field name_s + | `FField _ -> not_a_constructor name_s + | `FUnboxedField _ -> not_a_constructor name_s | `FPoly cs -> Ok (`PolyConstructor @@ -567,8 +577,8 @@ module F = struct env_lookup_by_name Env.s_field name env >>= fun (`Field (id, _)) -> Ok (`Identifier id :> t) - let got_a_constructor name = - (* Let's pretend we didn't see the constructor and say we didn't find anything. *) + let not_a_field name = + (* Let's pretend we didn't see the constructor/unboxed field and say we didn't find anything. *) Error (`Find_by_name (`Field, name)) let in_parent _env (parent : fragment_type_parent_lookup_result) name = @@ -577,16 +587,18 @@ module F = struct | `S (parent', parent_cp, sg) -> ( let sg = Tools.prefix_signature (parent_cp, sg) in find_ambiguous Find.any_in_type_in_sig sg name_s >>= function - | `In_type (_, _, `FConstructor _) -> got_a_constructor name_s - | `In_type (_, _, `FPoly _) -> got_a_constructor name_s + | `In_type (_, _, `FConstructor _) -> not_a_field name_s + | `In_type (_, _, `FPoly _) -> not_a_field name_s + | `In_type (_, _, `FUnboxedField _) -> not_a_field name_s | `In_type (typ_name, _, `FField _) -> Ok (`Field ((`Type (parent', typ_name) :> Resolved.FieldParent.t), name))) | `T (parent', t) -> ( find Find.any_in_type t (fun x -> x) name_s >>= function - | `FConstructor _ -> got_a_constructor name_s - | `FPoly _ -> got_a_constructor name_s + | `FConstructor _ -> not_a_field name_s + | `FPoly _ -> not_a_field name_s + | `FUnboxedField _ -> not_a_field name_s | `FField _ -> Ok (`Field ((parent' :> Resolved.FieldParent.t), name))) let of_component _env parent name = @@ -596,6 +608,46 @@ module F = struct FieldName.make_std name )) end +module UF = struct + (** Unboxed field *) + + type t = Resolved.UnboxedField.t + + let in_env env name = + env_lookup_by_name Env.s_unboxed_field name env >>= fun (`UnboxedField (id, _)) -> + Ok (`Identifier id :> t) + + let not_an_unboxed_field name = + (* Let's pretend we didn't see the constructor/field and say we didn't find anything. *) + Error (`Find_by_name (`UnboxedField, name)) + + let in_parent _env (parent : fragment_type_parent_lookup_result) name = + let name_s = UnboxedFieldName.to_string name in + match parent with + | `S (parent', parent_cp, sg) -> ( + let sg = Tools.prefix_signature (parent_cp, sg) in + find_ambiguous Find.any_in_type_in_sig sg name_s >>= function + | `In_type (_, _, `FConstructor _) -> not_an_unboxed_field name_s + | `In_type (_, _, `FPoly _) -> not_an_unboxed_field name_s + | `In_type (_, _, `FField _) -> not_an_unboxed_field name_s + | `In_type (typ_name, _, `FUnboxedField _) -> + Ok + (`UnboxedField + ((`Type (parent', typ_name) :> Resolved.UnboxedFieldParent.t), name))) + | `T (parent', t) -> ( + find Find.any_in_type t (fun x -> x) name_s >>= function + | `FConstructor _ -> not_an_unboxed_field name_s + | `FPoly _ -> not_an_unboxed_field name_s + | `FField _ -> not_an_unboxed_field name_s + | `FUnboxedField _ -> Ok (`UnboxedField ((parent' :> Resolved.UnboxedFieldParent.t), name))) + + let of_component _env parent name = + Ok + (`UnboxedField + ( (parent : Resolved.DataType.t :> Resolved.UnboxedFieldParent.t), + UnboxedFieldName.make_std name )) +end + module MM = struct (** Method *) @@ -872,7 +924,8 @@ let resolve_reference_dot_sg env ~parent_path ~parent_ref ~parent_sg name = match r with | `FConstructor _ -> CS.of_component env parent name >>= resolved1 | `FPoly p -> CS.poly_of_component env parent p.name >>= resolved1 - | `FField _ -> F.of_component env parent name >>= resolved1) + | `FField _ -> F.of_component env parent name >>= resolved1 + | `FUnboxedField _ -> UF.of_component env parent name >>= resolved1) | `FModule_subst _ | `FType_subst _ | `FModuleType_subst _ -> Error (`Find_by_name (`Any, name)) @@ -884,6 +937,7 @@ let resolve_reference_dot_type env ~parent_ref t name = | `FConstructor _ -> CS.of_component env parent_ref name >>= resolved1 | `FPoly p -> CS.poly_of_component env parent_ref p.name >>= resolved1 | `FField _ -> F.of_component env parent_ref name >>= resolved1 + | `FUnboxedField _ -> UF.of_component env parent_ref name >>= resolved1 let resolve_reference_dot_class env p name = type_lookup_to_class_signature_lookup env p >>= fun (parent_ref, cs) -> @@ -931,6 +985,7 @@ let resolve_reference : | `Extension (id, _, _) -> identifier id | `ExtensionDecl (id, _) -> identifier id | `Field (id, _) -> identifier id + | `UnboxedField (id, _) -> identifier id | `Page (id, _) -> identifier id) | `Resolved r -> Ok (r, None) | `Root (name, (`TModule | `TChildModule)) -> M.in_env env name >>= resolved @@ -985,6 +1040,10 @@ let resolve_reference : | `Field (parent, name) -> resolve_fragment_type_parent_reference env parent >>= fun p -> F.in_parent env p name >>= resolved1 + | `Root (name, `TUnboxedField) -> UF.in_env env name >>= resolved1 + | `UnboxedField (parent, name) -> + resolve_fragment_type_parent_reference env parent >>= fun p -> + UF.in_parent env p name >>= resolved1 | `Root (name, `TMethod) -> MM.in_env env name >>= resolved1 | `Method (parent, name) -> resolve_class_signature_reference env parent >>= fun p -> diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index c01ed5390b..0aa8ffa350 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -49,7 +49,7 @@ let rec shape_of_id env : | `ClassType (parent, name) -> proj parent Kind.Class_type (TypeName.to_string_unsafe name) | `Page _ | `LeafPage _ | `Label _ - | `Constructor _ | `Field _ | `Method _ | `InstanceVariable _ | `Parameter _ + | `Constructor _ | `Field _ | `UnboxedField _ | `Method _ | `InstanceVariable _ | `Parameter _ -> (* Not represented in shapes. *) None @@ -118,6 +118,7 @@ let unit_of_uid uid = | Item { comp_unit; _ } -> Some comp_unit | Predef _ -> None | Internal -> None + | Unboxed_version _ -> None #if OCAML_VERSION >= (5,2,0) let rec traverse_aliases = function diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index e4f987f4d2..efb75ee30c 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -125,6 +125,8 @@ let rec substitute_vars vars t = Arrow (lbl, substitute_vars vars t1, substitute_vars vars t2) | Tuple ts -> Tuple (List.map (fun (lbl, ty) -> (lbl, substitute_vars vars ty)) ts) + | Unboxed_tuple ts -> + Unboxed_tuple (List.map (fun (l, t) -> l, substitute_vars vars t) ts) | Constr (p, ts) -> Constr (p, List.map (substitute_vars vars) ts) | Polymorphic_variant v -> Polymorphic_variant (substitute_vars_poly_variant vars v) @@ -489,6 +491,8 @@ and type_decl_representation s t = match t with | Variant cs -> Variant (List.map (type_decl_constructor s) cs) | Record fs -> Record (List.map (type_decl_field s) fs) + | Record_unboxed_product fs -> + Record_unboxed_product (List.map (type_decl_unboxed_field s) fs) | Extensible -> t and type_decl_constructor s t = @@ -548,6 +552,7 @@ and type_expr s t = | Alias (t, str) -> Alias (type_expr s t, str) | Arrow (lbl, t1, t2) -> Arrow (lbl, type_expr s t1, type_expr s t2) | Tuple ts -> Tuple (List.map (fun (lbl, ty) -> (lbl, type_expr s ty)) ts) + | Unboxed_tuple ts -> Unboxed_tuple (List.map (fun (l, t) -> l, type_expr s t) ts) | Constr (p, ts) -> ( match type_path s p with | Replaced (t, eq) -> @@ -698,6 +703,10 @@ and type_decl_field s f = let open Component.TypeDecl.Field in { f with type_ = type_expr s f.type_ } +and type_decl_unboxed_field s f = + let open Component.TypeDecl.UnboxedField in + { f with type_ = type_expr s f.type_ } + and type_decl_constructor_arg s a = let open Component.TypeDecl.Constructor in match a with diff --git a/test/odoc_print/type_desc_to_yojson.ml b/test/odoc_print/type_desc_to_yojson.ml index 3f951850cc..90cde5bd20 100644 --- a/test/odoc_print/type_desc_to_yojson.ml +++ b/test/odoc_print/type_desc_to_yojson.ml @@ -10,6 +10,9 @@ let rec to_yojson : type a. a t -> a -> yojson = | Record fields -> let field_to_yojson (F (name, get, t)) = (name, to_yojson t (get a)) in `Assoc (List.map field_to_yojson fields) + | Unboxed_record fields -> + let field_to_yojson (UF (name, get, t)) = (name, to_yojson t (get a)) in + `Assoc (List.map field_to_yojson fields) | Variant get -> ( match get a with | C0 name -> `String name From 2cc197eff88284ce9282888aaf3d4fd089b9f0b2 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 17 Jul 2025 07:40:42 -0400 Subject: [PATCH 16/25] Remember the build directory from a .cmt or .cmti (#16) --- src/loader/cmt.ml | 2 ++ src/loader/cmt.mli | 2 ++ src/loader/cmti.mli | 1 + src/loader/odoc_loader.ml | 3 +++ 4 files changed, 8 insertions(+) diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 748eaec8c9..d4907d3daf 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -31,6 +31,8 @@ type env = Cmi.env = { } +let cmt_builddir : string ref = ref "" + let read_core_type env ctyp = Cmi.read_type_expr env ctyp.ctyp_type diff --git a/src/loader/cmt.mli b/src/loader/cmt.mli index 75ef06dda9..deabbd9d96 100644 --- a/src/loader/cmt.mli +++ b/src/loader/cmt.mli @@ -14,6 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +val cmt_builddir : string ref + val read_implementation : Odoc_model.Paths.Identifier.ContainerPage.t option -> string -> diff --git a/src/loader/cmti.mli b/src/loader/cmti.mli index c7048fea26..d2e5905a2d 100644 --- a/src/loader/cmti.mli +++ b/src/loader/cmti.mli @@ -16,6 +16,7 @@ module Paths = Odoc_model.Paths +val cmti_builddir : string ref val read_module_expr : (Cmi.env -> Paths.Identifier.Signature.t -> diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index e6f0eda7cd..95415b2927 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -125,6 +125,7 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = cmt_info.cmt_source_digest, cmt_info.cmt_builddir ) in + Cmti.cmti_builddir := cmt_info.cmt_builddir; let id, sg, canonical = Cmti.read_interface parent name ~warnings_tag intf in @@ -197,6 +198,8 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = make_compilation_unit ~make_root ~imports ~interface ~sourcefile ~name ~id content | Implementation impl -> + Cmt.cmt_builddir := cmt_info.cmt_builddir; + Cmti.cmti_builddir := cmt_info.cmt_builddir; let id, sg, canonical = Cmt.read_implementation parent name ~warnings_tag impl in From c9ea5afdf74fc6b728f664b5f7bf0da69b616555 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 17 Jul 2025 07:44:44 -0400 Subject: [PATCH 17/25] Adapt to constant `Cmxa` constructor in OxCaml (#17) --- src/odoc/classify.cppo.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/odoc/classify.cppo.ml b/src/odoc/classify.cppo.ml index ffbc8648d3..2defa8f329 100644 --- a/src/odoc/classify.cppo.ml +++ b/src/odoc/classify.cppo.ml @@ -197,7 +197,7 @@ let read_library ic init = let open Magic_number in match read_current_info ~expected_kind:None ic with | Ok { kind = Cma; version = _ } -> read_cma ic init - | Ok { kind = Cmxa _; version = _ } -> read_cmxa ic init + | Ok { kind = Cmxa; version = _ } -> read_cmxa ic init | Ok { kind = _; version = _ } -> Error (`Msg "Not a valid library") | Error _ -> Error (`Msg "Not a valid file") #else From c34ca204730845b7991bd84f79501b36a6649fbe Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 17 Jul 2025 07:56:06 -0400 Subject: [PATCH 18/25] Support OxCaml syntactic tokens in syntax highlighter (#20) --- src/syntax_highlighter/syntax_highlighter.ml | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/syntax_highlighter/syntax_highlighter.ml b/src/syntax_highlighter/syntax_highlighter.ml index 2a4732f831..01bbcafe2e 100644 --- a/src/syntax_highlighter/syntax_highlighter.ml +++ b/src/syntax_highlighter/syntax_highlighter.ml @@ -7,6 +7,8 @@ let tag_of_token (tok : Parser.token) = | AND -> "AND" | AS -> "AS" | ASSERT -> "ASSERT" + | AT -> "AT" + | ATAT -> "ATAT" | BACKQUOTE -> "BACKQUOTE" | BANG -> "BANG" | BAR -> "BAR" @@ -19,6 +21,7 @@ let tag_of_token (tok : Parser.token) = | COLONCOLON -> "COLONCOLON" | COLONEQUAL -> "COLONEQUAL" | COLONGREATER -> "COLONGREATER" + | COLONRBRACKET -> "COLONRBRACKET" | COMMA -> "COMMA" | COMMENT _ -> "COMMENT" | CONSTRAINT -> "CONSTRAINT" @@ -27,6 +30,7 @@ let tag_of_token (tok : Parser.token) = | DONE -> "DONE" | DOT -> "DOT" | DOTDOT -> "DOTDOT" + | DOTHASH -> "DOTHASH" | DOWNTO -> "DOWNTO" | ELSE -> "ELSE" | END -> "END" @@ -34,6 +38,7 @@ let tag_of_token (tok : Parser.token) = | EOL -> "EOL" | EQUAL -> "EQUAL" | EXCEPTION -> "EXCEPTION" + | EXCLAVE -> "EXCLAVE" | EXTERNAL -> "EXTERNAL" | FALSE -> "FALSE" | FLOAT _ -> "FLOAT" @@ -41,9 +46,15 @@ let tag_of_token (tok : Parser.token) = | FUN -> "FUN" | FUNCTION -> "FUNCTION" | FUNCTOR -> "FUNCTOR" + | GLOBAL -> "GLOBAL" | GREATER -> "GREATER" | GREATERRBRACE -> "GREATERRBRACE" | GREATERRBRACKET -> "GREATERRBRACKET" + | HASH_FLOAT _ -> "HASH_FLOAT" + | HASH_INT _ -> "HASH_INT" + | HASH_SUFFIX -> "HASH_SUFFIX" + | HASHLBRACE -> "HASHLBRACE" + | HASHLPAREN -> "HASHLPAREN" | IF -> "IF" | IN -> "IN" | INCLUDE -> "INCLUDE" @@ -55,6 +66,8 @@ let tag_of_token (tok : Parser.token) = | INHERIT -> "INHERIT" | INITIALIZER -> "INITIALIZER" | INT _ -> "INT" + | KIND_ABBREV -> "KIND_ABBREV" + | KIND_OF -> "KIND_OF" | LABEL _ -> "LABEL" | LAZY -> "LAZY" | LBRACE -> "LBRACE" @@ -64,6 +77,7 @@ let tag_of_token (tok : Parser.token) = | LBRACKETATAT -> "LBRACKETATAT" | LBRACKETATATAT -> "LBRACKETATATAT" | LBRACKETBAR -> "LBRACKETBAR" + | LBRACKETCOLON -> "LBRACKETCOLON" | LBRACKETGREATER -> "LBRACKETGREATER" | LBRACKETLESS -> "LBRACKETLESS" | LBRACKETPERCENT -> "LBRACKETPERCENT" @@ -73,21 +87,25 @@ let tag_of_token (tok : Parser.token) = | LET -> "LET" | LIDENT "failwith" -> "failwith" | LIDENT _ -> "LIDENT" + | LOCAL -> "LOCAL" | LPAREN -> "LPAREN" | MATCH -> "MATCH" | METHOD -> "METHOD" | MINUS -> "MINUS" | MINUSDOT -> "MINUSDOT" | MINUSGREATER -> "MINUSGREATER" + | MOD -> "MOD" | MODULE -> "MODULE" | MUTABLE -> "MUTABLE" | NEW -> "NEW" | NONREC -> "NONREC" | OBJECT -> "OBJECT" | OF -> "OF" + | ONCE -> "ONCE" | OPEN -> "OPEN" | OPTLABEL _ -> "OPTLABEL" | OR -> "OR" + | OVERWRITE -> "OVERWRITE" | PERCENT -> "PERCENT" | PLUS -> "PLUS" | PLUSDOT -> "PLUSDOT" @@ -103,6 +121,7 @@ let tag_of_token (tok : Parser.token) = | SEMI -> "SEMI" | SEMISEMI -> "SEMISEMI" | SIG -> "SIG" + | STACK -> "STACK" | STAR -> "STAR" | STRING _ -> "STRING" | STRUCT -> "STRUCT" @@ -114,6 +133,7 @@ let tag_of_token (tok : Parser.token) = | TYPE -> "TYPE" | UIDENT _ -> "UIDENT" | UNDERSCORE -> "UNDERSCORE" + | UNIQUE -> "UNIQUE" | VAL -> "VAL" | VIRTUAL -> "VIRTUAL" | WHEN -> "WHEN" From 4af881321227d26d365e219992c6e593414affda Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 17 Jul 2025 07:58:05 -0400 Subject: [PATCH 19/25] Update integration test (#21) --- test/integration/json_expansion_with_sources.t/run.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/integration/json_expansion_with_sources.t/run.t b/test/integration/json_expansion_with_sources.t/run.t index ffc54de878..f1eefc6391 100644 --- a/test/integration/json_expansion_with_sources.t/run.t +++ b/test/integration/json_expansion_with_sources.t/run.t @@ -47,4 +47,4 @@ Test the JSON output in the presence of expanded modules. {"header":"

Module A.BSource

","type":"documentation","uses_katex":false,"breadcrumbs":[{"name":"Index","href":"../../../index.html","kind":"leaf-page"},{"name":"Main","href":"../../index.html","kind":"module"},{"name":"A","href":"../index.html","kind":"module"},{"name":"B","href":"#","kind":"module"}],"toc":[],"source_anchor":"../../../src/a.ml.html#module-B","preamble":"","content":""} $ cat html/src/a.ml.html.json - {"type":"source","breadcrumbs":[{"name":"Index","href":"../index.html","kind":"leaf-page"},{"name":"src","href":"index.html","kind":"page"},{"name":"a.ml","href":"#","kind":"source"}],"global_toc":null,"header":"

Source file a.ml

","content":"
1\u000Amodule B = struct end\u000A
"} + {"type":"source","breadcrumbs":[{"name":"Index","href":"../index.html","kind":"leaf-page"},{"name":"src","href":"index.html","kind":"page"},{"name":"a.ml","href":"#","kind":"source"}],"global_toc":null,"header":"

Source file a.ml

","content":"
1\u000Amodule B = struct end\u000A
"} From 148f1b2d518348c6816fc8eb4b8a4e72e5be201b Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Mon, 8 Dec 2025 15:19:37 +0100 Subject: [PATCH 20/25] Fix for OxCaml 5.2.0-23 --- sherlodoc/index/load_doc.ml | 7 ++++--- src/loader/cmi.ml | 8 ++++++++ src/loader/cmt.ml | 4 ++-- src/loader/cmti.ml | 4 ++++ src/loader/ident_env.cppo.ml | 4 ++-- src/loader/typedtree_traverse.ml | 4 ++-- src/syntax_highlighter/syntax_highlighter.ml | 8 ++++++++ src/xref2/env.ml | 12 +++++++++--- src/xref2/shape_tools.cppo.ml | 8 ++++++++ 9 files changed, 47 insertions(+), 12 deletions(-) diff --git a/sherlodoc/index/load_doc.ml b/sherlodoc/index/load_doc.ml index 5ce0945db9..31b5ebfdb9 100644 --- a/sherlodoc/index/load_doc.ml +++ b/sherlodoc/index/load_doc.ml @@ -116,7 +116,8 @@ let convert_kind ~db (Odoc_index.Entry.{ kind; _ } as entry) = let typ = searchable_type_of_constructor args res in let typ = Db_writer.type_of_odoc ~db typ in Entry.Kind.Exception typ - | Field { mutable_ = _; parent_type; type_ } -> + | Field { mutable_ = _; parent_type; type_ } + | UnboxedField { mutable_ = _; parent_type; type_ } -> let typ = searchable_type_of_record parent_type type_ in let typ = Db_writer.type_of_odoc ~db typ in Entry.Kind.Field typ @@ -149,7 +150,7 @@ let rec categorize id = | `Parameter _ -> `ignore (* redundant with indexed signature *) | ( `InstanceVariable _ | `Method _ | `Field _ | `Result _ | `Label _ | `Type _ | `Exception _ | `Class _ | `ClassType _ | `Value _ | `Constructor _ | `Extension _ - | `ExtensionDecl _ | `Module _ ) as x -> + | `ExtensionDecl _ | `Module _ | `UnboxedField _ ) as x -> let parent = Identifier.label_parent { id with iv = x } in categorize (parent :> Identifier.Any.t) | `AssetFile _ | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _ @@ -173,7 +174,7 @@ let register_entry ~favoured_prefixes ~pkg ~cat - (Odoc_index.Entry.{ id; doc; kind } as entry) + (Odoc_index.Entry.{ id; doc; kind; source_loc = _ } as entry) = let module Sherlodoc_entry = Entry in let open Odoc_search in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index bce9a5bab8..4d0a8d6072 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -304,6 +304,10 @@ let mark_type ty = | Tsubst ty -> loop visited ty #else | Tsubst (ty,_) -> loop visited ty +#endif +#if OCAML_VERSION = (5,2,0) + | Tquote typ -> loop visited typ + | Tsplice typ -> loop visited typ #endif | Tlink _ -> assert false | Tof_kind _ -> () @@ -551,6 +555,10 @@ let rec read_type_expr env typ = | Tsubst typ -> read_type_expr env typ #else | Tsubst (typ,_) -> read_type_expr env typ +#endif +#if OCAML_VERSION = (5,2,0) + | Tquote typ -> read_type_expr env typ + | Tsplice typ -> read_type_expr env typ #endif | Tlink _ -> assert false | Tof_kind _ -> assert false diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index d4907d3daf..98a9536db2 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -44,7 +44,7 @@ let rec read_pattern env parent doc pat = #if OCAML_VERSION < (5,2,0) | Tpat_var(id, _, _, _) -> #else - | Tpat_var(id,_,_uid, _) -> + | Tpat_var(id, _, _uid, _, _) -> #endif let open Value in let id = Env.find_value_identifier env.ident_env id in @@ -56,7 +56,7 @@ let rec read_pattern env parent doc pat = #if OCAML_VERSION < (5,2, 0) | Tpat_alias(pat, id, _) -> #elif OCAML_VERSION = (5,2, 0) - | Tpat_alias(pat, id, _,_, _, _) -> + | Tpat_alias(pat, id, _, _, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, _,_) -> #else diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 7ec6897118..6036c707dd 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -182,6 +182,10 @@ let rec read_core_type env container ctyp = | Ttyp_open (_p,_l,t) -> (* TODO: adjust model *) read_core_type env container t +#endif +#if OCAML_VERSION = (5,2,0) + | Ttyp_quote typ -> read_core_type env container typ + | Ttyp_splice typ -> read_core_type env container typ #endif | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, []) | Ttyp_of_kind _ -> assert false diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 8bdab8aa3a..bb38eda553 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -305,13 +305,13 @@ let rec read_pattern hide_item pat = #if OCAML_VERSION < (5,2,0) | Tpat_var(id, loc, _, _) -> #else - | Tpat_var(id, loc, _, _) -> + | Tpat_var(id, loc, _, _, _) -> #endif [`Value(id, hide_item, Some loc.loc)] #if OCAML_VERSION < (5,2,0) | Tpat_alias(pat, id, loc) -> #elif OCAML_VERSION = (5,2,0) - | Tpat_alias(pat, id, loc, _, _, _) -> + | Tpat_alias(pat, id, loc, _, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, loc, _) -> #else diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index ec9b8bf9ec..ab501d3b4d 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -26,7 +26,7 @@ module Analysis = struct let () = match pat_desc with #if OCAML_VERSION >= (5, 2, 0) - | Tpat_var (id, loc, _uid, _) -> ( + | Tpat_var (id, loc, _uid, _, _) -> ( #else | Tpat_var (id, loc, _, _) -> ( #endif @@ -36,7 +36,7 @@ module Analysis = struct #if OCAML_VERSION >= (5, 4, 0) | Tpat_alias (_, id, loc, _uid, _ty) -> ( #elif OCAML_VERSION = (5, 2, 0) - | Tpat_alias (_, id, loc, _uid, _, _) -> ( + | Tpat_alias (_, id, loc, _uid, _, _, _) -> ( #elif OCAML_VERSION >= (5, 2, 0) | Tpat_alias (_, id, loc, _uid) -> ( #else diff --git a/src/syntax_highlighter/syntax_highlighter.ml b/src/syntax_highlighter/syntax_highlighter.ml index 01bbcafe2e..99bd8dc782 100644 --- a/src/syntax_highlighter/syntax_highlighter.ml +++ b/src/syntax_highlighter/syntax_highlighter.ml @@ -165,6 +165,13 @@ let tag_of_token (tok : Parser.token) = | ANDOP _ -> "ANDOP" | LETOP _ -> "LETOP" #endif +#if OCAML_VERSION = (5,2,0) + (* oxcaml *) + | RBRACKETGREATER -> "RBRACKETGREATER" + | LESSLBRACKET -> "LESSLBRACKET" + | DOLLAR -> "DOLLAR" + | HASH_CHAR _ -> "HASH_CHAR" +#endif #if OCAML_VERSION >= (5,3,0) | METAOCAML_ESCAPE -> "METAOCAML_ESCAPE" | METAOCAML_BRACKET_OPEN -> "METAOCAML_BRACKET_OPEN" @@ -172,6 +179,7 @@ let tag_of_token (tok : Parser.token) = | EFFECT -> "EFFECT" #endif + let syntax_highlighting_locs src = try Lexer.init (); diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 1c25956c07..0dccefc7a2 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -168,7 +168,9 @@ type t = { ids : ElementsById.t; (** Elements mapped by their identifier. Queried with {!find_by_id}. *) ambiguous_labels : Component.Element.label amb_err Identifier.Maps.Label.t; - ambiguous_unboxed_labels : Component.Element.label amb_err Identifier.Maps.Label.t; + ambiguous_unboxed_labels : + Component.Element.label amb_err Identifier.Maps.Label.t; + [@warning "-unused-field"] resolver : resolver option; recorder : recorder option; warnings_tags : string list; @@ -284,7 +286,9 @@ let add_docs (docs : Comment.docs) env = (fun env -> function | { Location_.value = `Heading (attrs, id, text); location } -> let label = Ident.Of_Identifier.label id in - add_label id { Component.Label.attrs; label; text; location } env ~unboxed:false + add_label id + { Component.Label.attrs; label; text; location } + env ~unboxed:false | _ -> env) env docs.elements @@ -643,7 +647,9 @@ let s_field : Component.Element.field scope = make_scope (function #Component.Element.field as r -> Some r | _ -> None) let s_unboxed_field : Component.Element.unboxed_field scope = - make_scope (function #Component.Element.unboxed_field as r -> Some r | _ -> None) + make_scope (function + | #Component.Element.unboxed_field as r -> Some r + | _ -> None) let s_label_parent : Component.Element.label_parent scope = make_scope ~root:lookup_page_or_root_module_fallback (function diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index 0aa8ffa350..1371f99dab 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -156,6 +156,14 @@ let lookup_shape : Env.t -> Shape.t -> Identifier.SourceLocation.t option = | Some (shape, _) -> Some shape | None -> None) | _ -> None +#if OCAML_VERSION = (5,2,0) + let fuel () = Misc.Maybe_bounded.of_int fuel + let projection_rules_for_merlin_enabled = false + let fuel_for_compilation_units = fuel + let max_shape_reduce_steps_per_variable = fuel + let max_compilation_unit_depth = fuel + let read_unit_shape ~diagnostics:_ ~unit_name = read_unit_shape ~unit_name +#endif end) in let result = try Some (Reduce.reduce_for_uid Ocaml_env.empty query) with Not_found -> None in result >>= traverse_aliases >>= fun uid -> From f05e08754ed9023128e498b46c51bc007b9f4682 Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Mon, 8 Dec 2025 16:09:36 +0100 Subject: [PATCH 21/25] Support for type quote and splice --- src/document/generator.ml | 4 ++++ src/loader/cmi.ml | 4 ++-- src/loader/cmti.ml | 4 ++-- src/model/lang.ml | 2 ++ src/model_desc/lang_desc.ml | 2 ++ src/xref2/compile.ml | 2 ++ src/xref2/component.ml | 6 ++++++ src/xref2/component.mli | 2 ++ src/xref2/expand_tools.ml | 2 ++ src/xref2/lang_of.ml | 2 ++ src/xref2/link.ml | 2 ++ src/xref2/subst.ml | 4 ++++ 12 files changed, 32 insertions(+), 4 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 831cc8a302..ee3792868b 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -479,6 +479,10 @@ module Make (Syntax : SYNTAX) = struct (Link.from_path (path :> Paths.Path.t)) | Poly (polyvars, t) -> O.txt ("'" ^ String.concat ~sep:" '" polyvars ^ ". ") ++ type_expr t + | Quote t -> + O.span (O.txt "<[ " ++ O.box_hv (type_expr t) ++ O.txt " ]>") + | Splice t -> + O.span (O.txt "$" ++ type_expr ~needs_parentheses:true t) | Package pkg -> enclose ~l:"(" ~r:")" (O.keyword "module" ++ O.txt " " diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 4d0a8d6072..baa7cf345d 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -557,8 +557,8 @@ let rec read_type_expr env typ = | Tsubst (typ,_) -> read_type_expr env typ #endif #if OCAML_VERSION = (5,2,0) - | Tquote typ -> read_type_expr env typ - | Tsplice typ -> read_type_expr env typ + | Tquote typ -> Quote (read_type_expr env typ) + | Tsplice typ -> Splice (read_type_expr env typ) #endif | Tlink _ -> assert false | Tof_kind _ -> assert false diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 6036c707dd..897d941f7e 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -184,8 +184,8 @@ let rec read_core_type env container ctyp = read_core_type env container t #endif #if OCAML_VERSION = (5,2,0) - | Ttyp_quote typ -> read_core_type env container typ - | Ttyp_splice typ -> read_core_type env container typ + | Ttyp_quote typ -> Quote (read_core_type env container typ) + | Ttyp_splice typ -> Splice (read_core_type env container typ) #endif | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, []) | Ttyp_of_kind _ -> assert false diff --git a/src/model/lang.ml b/src/model/lang.ml index a33b8c6703..300fee5eba 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -481,6 +481,8 @@ and TypeExpr : sig | Object of TypeExpr.Object.t | Class of Path.ClassType.t * t list | Poly of string list * t + | Quote of t + | Splice of t | Package of TypeExpr.Package.t end = TypeExpr diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 53cf227182..5c509481e9 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -666,6 +666,8 @@ and typeexpr_t = | Class (x1, x2) -> C ("Class", ((x1 :> Paths.Path.t), x2), Pair (path, List typeexpr_t)) | Poly (x1, x2) -> C ("Poly", (x1, x2), Pair (List string, typeexpr_t)) + | Quote x -> C ("Quote", x, typeexpr_t) + | Splice x -> C ("Splice", x, typeexpr_t) | Package x -> C ("Package", x, typeexpr_package)) (** {3 Compilation_unit} *) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index aa5042bea3..3873010d1c 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -947,6 +947,8 @@ and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ = Class (`Resolved p, ts') | _ -> Class (path, ts')) | Poly (strs, t) -> Poly (strs, type_expression env parent t) + | Quote t -> Quote (type_expression env parent t) + | Splice t -> Splice (type_expression env parent t) | Package p -> Package (type_expression_package env parent p) let compile ~filename env compilation_unit = diff --git a/src/xref2/component.ml b/src/xref2/component.ml index f81c03d491..6bc682e5ad 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -130,6 +130,8 @@ and TypeExpr : sig | Object of TypeExpr.Object.t | Class of Cpath.class_type * t list | Poly of string list * t + | Quote of t + | Splice of t | Package of TypeExpr.Package.t end = TypeExpr @@ -1203,6 +1205,8 @@ module Fmt = struct | Object x -> type_object c ppf x | Class (x, y) -> type_class c ppf (x, y) | Poly (_ss, _t) -> Format.fprintf ppf "(poly)" + | Quote t -> Format.fprintf ppf "(quote %a)" (type_expr c) t + | Splice t -> Format.fprintf ppf "(splice %a)" (type_expr c) t | Package x -> type_package c ppf x and resolved_module_path : @@ -2346,6 +2350,8 @@ module Of_Lang = struct Class (class_type_path ident_map p, List.map (type_expression ident_map) ts) | Object o -> Object (type_object ident_map o) + | Quote t -> Quote (type_expression ident_map t) + | Splice t -> Splice (type_expression ident_map t) | Package p -> Package (type_package ident_map p) and module_decl ident_map m = diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 1b87f376a1..aab0e19ec6 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -125,6 +125,8 @@ and TypeExpr : sig | Object of TypeExpr.Object.t | Class of Cpath.class_type * t list | Poly of string list * t + | Quote of t + | Splice of t | Package of TypeExpr.Package.t end diff --git a/src/xref2/expand_tools.ml b/src/xref2/expand_tools.ml index 5b9a0942f5..7d28e5b488 100644 --- a/src/xref2/expand_tools.ml +++ b/src/xref2/expand_tools.ml @@ -65,6 +65,8 @@ let rec type_expr map t = | Class (path, ts) -> Class (path, List.map (type_expr map) ts) | Poly (s, t) -> Poly (s, type_expr map t) | Package p -> Package (package map p) + | Quote t -> Quote (type_expr map t) + | Splice t -> Splice (type_expr map t) and polymorphic_variant map pv = let open Lang.TypeExpr.Polymorphic_variant in diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 86845805d3..7cbfcf3ba7 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -1042,6 +1042,8 @@ and type_expr map (parent : Identifier.LabelParent.t) (t : Component.TypeExpr.t) | Class (p, ts) -> Class (Path.class_type map p, List.map (type_expr map parent) ts) | Poly (strs, t) -> Poly (strs, type_expr map parent t) + | Quote t -> Quote (type_expr map parent t) + | Splice t -> Splice (type_expr map parent t) | Package p -> Package (type_expr_package map parent p) with e -> let bt = Printexc.get_backtrace () in diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 778972e861..a52c8c361f 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -1202,6 +1202,8 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ = Class (`Resolved p, ts) | _ -> Class (path', ts)) | Poly (strs, t) -> Poly (strs, type_expression env parent visited t) + | Quote t -> Quote (type_expression env parent visited t) + | Splice t -> Splice (type_expression env parent visited t) | Package p -> Package (type_expression_package env parent visited p) let link ~filename x y = diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index efb75ee30c..daee32e456 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -133,6 +133,8 @@ let rec substitute_vars vars t = | Object o -> Object (substitute_vars_type_object vars o) | Class (p, ts) -> Class (p, List.map (substitute_vars vars) ts) | Poly (strs, ts) -> Poly (strs, substitute_vars vars ts) + | Quote t -> Quote (substitute_vars vars t) + | Splice t -> Splice (substitute_vars vars t) | Package p -> Package (substitute_vars_package vars p) and substitute_vars_package vars p = @@ -568,6 +570,8 @@ and type_expr s t = | Object o -> Object (type_object s o) | Class (p, ts) -> Class (class_type_path s p, List.map (type_expr s) ts) | Poly (strs, ts) -> Poly (strs, type_expr s ts) + | Quote t -> Quote (type_expr s t) + | Splice t -> Splice (type_expr s t) | Package p -> Package (type_package s p) and simple_expansion : From 35662638384df9bbe5344d9610300b0809a6fc6c Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Mon, 26 Jan 2026 11:53:56 +0100 Subject: [PATCH 22/25] Fix for OxCaml Val_reg Signed-off-by: Arthur Wendling --- src/loader/cmi.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index baa7cf345d..12b146da27 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -685,7 +685,11 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd = let type_ = read_type_expr env vd.val_type in let value = match vd.val_kind with +#if OCAML_VERSION = (5,2,0) + | Val_reg _ -> Value.Abstract +#else | Val_reg -> Value.Abstract +#endif | Val_prim desc -> let primitives = let open Primitive in From 93a93c262270458ca14dab069cdd8f6a6a3eb318 Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Tue, 27 Jan 2026 18:57:55 +0100 Subject: [PATCH 23/25] Simplify dune rules for ident_env cppo --- src/loader/dune | 18 ------------------ src/loader/{ident_env.cppo.ml => ident_env.ml} | 0 .../{ident_env.cppo.mli => ident_env.mli} | 0 3 files changed, 18 deletions(-) rename src/loader/{ident_env.cppo.ml => ident_env.ml} (100%) rename src/loader/{ident_env.cppo.mli => ident_env.mli} (100%) diff --git a/src/loader/dune b/src/loader/dune index f77d0b8fb6..644e8b8e6a 100644 --- a/src/loader/dune +++ b/src/loader/dune @@ -1,21 +1,3 @@ -(rule - (targets ident_env.ml) - (deps - (:x ident_env.cppo.ml)) - (action - (chdir - %{workspace_root} - (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) - -(rule - (targets ident_env.mli) - (deps - (:x ident_env.cppo.mli)) - (action - (chdir - %{workspace_root} - (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) - (library (name odoc_loader) (public_name odoc.loader) diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.ml similarity index 100% rename from src/loader/ident_env.cppo.ml rename to src/loader/ident_env.ml diff --git a/src/loader/ident_env.cppo.mli b/src/loader/ident_env.mli similarity index 100% rename from src/loader/ident_env.cppo.mli rename to src/loader/ident_env.mli From db33a213a287e5af666c9559fdff33e9036d58d1 Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Wed, 28 Jan 2026 10:00:51 +0100 Subject: [PATCH 24/25] Preprocess for OxCaml with ocaml-config:ox --- src/loader/cmi.ml | 20 ++++++++---------- src/loader/cmt.ml | 14 +++++++------ src/loader/cmti.ml | 8 +++---- src/loader/dune | 17 +++++++++++++++ src/loader/ident_env.ml | 14 +++++++------ src/model/compat.cppo.ml | 9 +++++++- src/model/dune | 12 +++++++++++ src/syntax_highlighter/dune | 11 ++++++++++ src/syntax_highlighter/syntax_highlighter.ml | 3 +-- src/xref2/dune | 22 +++++++++++++++++--- src/xref2/shape_tools.cppo.ml | 2 +- 11 files changed, 98 insertions(+), 34 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 12b146da27..727de39c0c 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -60,10 +60,8 @@ module Compat = struct let concr_mem = Types.Meths.mem let csig_concr x = x.Types.csig_meths let eq_type = Types.eq_type -#if OCAML_VERSION >= (5,4,0) +#if OCAML_VERSION >= (5,4,0) || defined OXCAML let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [None,ty]) -#elif OCAML_VERSION = (5,2,0) - let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [None, ty]) #else let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [ty]) #endif @@ -241,12 +239,12 @@ let mark_type ty = | Tarrow(_, ty1, ty2, _) -> loop visited ty1; loop visited ty2 -#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) +#if OCAML_VERSION >= (5,4,0) || defined OXCAML | Ttuple tyl -> List.iter (fun (_lbl,x) -> loop visited x) tyl #else | Ttuple tyl -> List.iter (loop visited) tyl #endif -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tunboxed_tuple tyl -> List.iter (fun (_, ty) -> loop visited ty) tyl #endif | Tconstr(_, tyl, _) -> @@ -285,7 +283,7 @@ let mark_type ty = | Tpoly (ty, tyl) -> List.iter (fun t -> add_alias t) tyl; loop visited ty -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tunivar { name; _ } -> reserve_name name #else | Tunivar name -> reserve_name name @@ -305,7 +303,7 @@ let mark_type ty = #else | Tsubst (ty,_) -> loop visited ty #endif -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tquote typ -> loop visited typ | Tsplice typ -> loop visited typ #endif @@ -504,13 +502,13 @@ let rec read_type_expr env typ = let res = read_type_expr env res in Arrow(lbl, arg, res) | Ttuple typs -> -#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) +#if OCAML_VERSION >= (5,4,0) || defined OXCAML let typs = List.map (fun (lbl,x) -> lbl, read_type_expr env x) typs in #else let typs = List.map (fun x -> None, read_type_expr env x) typs in #endif Tuple typs -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tunboxed_tuple typs -> let typs = List.map (fun (l,t) -> l, read_type_expr env t) typs in Unboxed_tuple typs @@ -556,7 +554,7 @@ let rec read_type_expr env typ = #else | Tsubst (typ,_) -> read_type_expr env typ #endif -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tquote typ -> Quote (read_type_expr env typ) | Tsplice typ -> Splice (read_type_expr env typ) #endif @@ -685,7 +683,7 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd = let type_ = read_type_expr env vd.val_type in let value = match vd.val_kind with -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Val_reg _ -> Value.Abstract #else | Val_reg -> Value.Abstract diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 98a9536db2..4ea8c61ee6 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -42,9 +42,11 @@ let rec read_pattern env parent doc pat = match pat.pat_desc with | Tpat_any -> [] #if OCAML_VERSION < (5,2,0) - | Tpat_var(id, _, _, _) -> -#else + | Tpat_var(id, _) -> +#elif defined OXCAML | Tpat_var(id, _, _uid, _, _) -> +#else + | Tpat_var(id, _, _uid) -> #endif let open Value in let id = Env.find_value_identifier env.ident_env id in @@ -55,7 +57,7 @@ let rec read_pattern env parent doc pat = [Value {id; source_loc; doc; type_; value ; source_loc_jane }] #if OCAML_VERSION < (5,2, 0) | Tpat_alias(pat, id, _) -> -#elif OCAML_VERSION = (5,2, 0) +#elif defined OXCAML | Tpat_alias(pat, id, _, _, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, _,_) -> @@ -71,11 +73,11 @@ let rec read_pattern env parent doc pat = Value {id; source_loc; doc; type_; value ; source_loc_jane } :: read_pattern env parent doc pat | Tpat_constant _ -> [] | Tpat_tuple pats -> -#if OCAML_VERSION >= (5, 4, 0) || OCAML_VERSION = (5, 2, 0) +#if OCAML_VERSION >= (5, 4, 0) || defined OXCAML let pats = List.map snd pats (* remove labels *) in #endif List.concat (List.map (read_pattern env parent doc) pats) -#if OCAML_VERSION = (5, 2, 0) +#if defined OXCAML | Tpat_unboxed_tuple pats -> List.concat (List.map (fun (_, p, _) -> read_pattern env parent doc p) pats) #endif @@ -93,7 +95,7 @@ let rec read_pattern env parent doc pat = (List.map (fun (_, _, pat) -> read_pattern env parent doc pat) pats) -#if OCAML_VERSION = (5, 2, 0) +#if defined OXCAML | Tpat_record_unboxed_product(pats, _) -> List.concat (List.map diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 897d941f7e..eeee68c4b8 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -67,13 +67,13 @@ let rec read_core_type env container ctyp = let res = read_core_type env container res in Arrow(lbl, arg, res) | Ttyp_tuple typs -> -#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) +#if OCAML_VERSION >= (5,4,0) || defined OXCAML let typs = List.map (fun (lbl,x) -> lbl, read_core_type env container x) typs in #else let typs = List.map (fun x -> None, read_core_type env container x) typs in #endif Tuple typs -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Ttyp_unboxed_tuple typs -> let typs = List.map (fun (l, t) -> l, read_core_type env container t) typs in Unboxed_tuple typs @@ -155,7 +155,7 @@ let rec read_core_type env container ctyp = in Polymorphic_variant {kind; elements} | Ttyp_poly([], typ) -> read_core_type env container typ -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Ttyp_poly(vars, typ) -> (* TODO: presumably want the layouts, eventually *) Poly(List.map fst vars, read_core_type env container typ) @@ -183,7 +183,7 @@ let rec read_core_type env container ctyp = (* TODO: adjust model *) read_core_type env container t #endif -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Ttyp_quote typ -> Quote (read_core_type env container typ) | Ttyp_splice typ -> Splice (read_core_type env container typ) #endif diff --git a/src/loader/dune b/src/loader/dune index 644e8b8e6a..055da90366 100644 --- a/src/loader/dune +++ b/src/loader/dune @@ -1,6 +1,8 @@ (library (name odoc_loader) (public_name odoc.loader) + (enabled_if + (not %{ocaml-config:ox})) (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) @@ -11,3 +13,18 @@ odoc_document odoc_utils compiler-libs.optcomp)) + +(library + (name odoc_loader) + (public_name odoc.loader) + (enabled_if %{ocaml-config:ox}) + (preprocess + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} -D "OXCAML" %{input-file}))) + (libraries + odoc_model + odoc-parser + syntax_highlighter + odoc_document + odoc_utils + compiler-libs.optcomp)) diff --git a/src/loader/ident_env.ml b/src/loader/ident_env.ml index bb38eda553..1dd570d018 100644 --- a/src/loader/ident_env.ml +++ b/src/loader/ident_env.ml @@ -303,14 +303,16 @@ let rec read_pattern hide_item pat = let open Typedtree in match pat.pat_desc with #if OCAML_VERSION < (5,2,0) - | Tpat_var(id, loc, _, _) -> -#else + | Tpat_var(id, loc) -> +#elif defined OXCAML | Tpat_var(id, loc, _, _, _) -> +#else + | Tpat_var(id, loc, _, _) -> #endif [`Value(id, hide_item, Some loc.loc)] #if OCAML_VERSION < (5,2,0) | Tpat_alias(pat, id, loc) -> -#elif OCAML_VERSION = (5,2,0) +#elif defined OXCAML | Tpat_alias(pat, id, loc, _, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, loc, _) -> @@ -327,7 +329,7 @@ let rec read_pattern hide_item pat = #else | Tpat_construct(_, _, pats, _) #endif -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tpat_array (_, _, pats) -> List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #elif OCAML_VERSION < (5,4,0) @@ -338,12 +340,12 @@ let rec read_pattern hide_item pat = List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #endif | Tpat_tuple pats -> -#if OCAML_VERSION >= (5,4,0) || OCAML_VERSION = (5,2,0) +#if OCAML_VERSION >= (5,4,0) || defined OXCAML List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats) #else List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #endif -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML | Tpat_unboxed_tuple pats -> List.concat (List.map (fun (_, pat, _) -> read_pattern hide_item pat) pats) #endif diff --git a/src/model/compat.cppo.ml b/src/model/compat.cppo.ml index b73518cbff..1cbf928e5d 100644 --- a/src/model/compat.cppo.ml +++ b/src/model/compat.cppo.ml @@ -284,11 +284,18 @@ let shape_info_of_cmt_infos : Cmt_format.cmt_infos -> (shape * uid_to_loc) optio #endif -#if OCAML_VERSION >= (5,2,0) +#if defined OXCAML + let compunit_name : Compilation_unit.t -> string = Compilation_unit.name_as_string let required_compunit_names x = List.map compunit_name x.Cmo_format.cu_required_compunits +#elif OCAML_VERSION >= (5,2,0) + +let compunit_name : Cmo_format.compunit -> string = function | Compunit x -> x + +let required_compunit_names x = List.map compunit_name x.Cmo_format.cu_required_compunits + #elif OCAML_VERSION >= (4,04,0) let compunit_name x = Compilation_unit.name_as_string x diff --git a/src/model/dune b/src/model/dune index 762fd475f5..4d396a43b2 100644 --- a/src/model/dune +++ b/src/model/dune @@ -2,11 +2,23 @@ (targets compat.ml) (deps (:x compat.cppo.ml)) + (enabled_if + (not %{ocaml-config:ox})) (action (chdir %{workspace_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) +(rule + (targets compat.ml) + (deps + (:x compat.cppo.ml)) + (enabled_if %{ocaml-config:ox}) + (action + (chdir + %{workspace_root} + (run %{bin:cppo} -V OCAML:%{ocaml_version} -D "OXCAML" %{x} -o %{targets})))) + (library (name odoc_model) (public_name odoc.model) diff --git a/src/syntax_highlighter/dune b/src/syntax_highlighter/dune index f5186ddba8..3ada3ef288 100644 --- a/src/syntax_highlighter/dune +++ b/src/syntax_highlighter/dune @@ -1,7 +1,18 @@ (library (name syntax_highlighter) (public_name odoc.syntax_highlighter) + (enabled_if + (not %{ocaml-config:ox})) (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) (libraries compiler-libs.common)) + +(library + (name syntax_highlighter) + (public_name odoc.syntax_highlighter) + (enabled_if %{ocaml-config:ox}) + (preprocess + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} -D OXCAML %{input-file}))) + (libraries compiler-libs.common)) diff --git a/src/syntax_highlighter/syntax_highlighter.ml b/src/syntax_highlighter/syntax_highlighter.ml index 99bd8dc782..d2ca418393 100644 --- a/src/syntax_highlighter/syntax_highlighter.ml +++ b/src/syntax_highlighter/syntax_highlighter.ml @@ -165,8 +165,7 @@ let tag_of_token (tok : Parser.token) = | ANDOP _ -> "ANDOP" | LETOP _ -> "LETOP" #endif -#if OCAML_VERSION = (5,2,0) - (* oxcaml *) +#if defined OXCAML | RBRACKETGREATER -> "RBRACKETGREATER" | LESSLBRACKET -> "LESSLBRACKET" | DOLLAR -> "DOLLAR" diff --git a/src/xref2/dune b/src/xref2/dune index 705719672f..f61d3d001c 100644 --- a/src/xref2/dune +++ b/src/xref2/dune @@ -8,9 +8,25 @@ (libraries odoc_model odoc_utils)) (rule - (with-stdout-to - shape_tools.ml - (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:shape_tools.cppo.ml}))) + (enabled_if + (not %{ocaml-config:ox})) + (action + (with-stdout-to + shape_tools.ml + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:shape_tools.cppo.ml})))) + +(rule + (enabled_if %{ocaml-config:ox}) + (action + (with-stdout-to + shape_tools.ml + (run + %{bin:cppo} + -V + OCAML:%{ocaml_version} + -D + OXCAML + %{dep:shape_tools.cppo.ml})))) (rule (with-stdout-to diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index 1371f99dab..ff5d9a9f6f 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -156,7 +156,7 @@ let lookup_shape : Env.t -> Shape.t -> Identifier.SourceLocation.t option = | Some (shape, _) -> Some shape | None -> None) | _ -> None -#if OCAML_VERSION = (5,2,0) +#if defined OXCAML let fuel () = Misc.Maybe_bounded.of_int fuel let projection_rules_for_merlin_enabled = false let fuel_for_compilation_units = fuel From bb20ded6984bf1a0b031c48eb0a474aa53cf256b Mon Sep 17 00:00:00 2001 From: Arthur Wendling Date: Wed, 28 Jan 2026 10:45:16 +0100 Subject: [PATCH 25/25] Add missing OXCAML preprocessing --- src/loader/cmi.ml | 91 ++++++++++++++++---- src/loader/cmi.mli | 5 +- src/loader/cmt.ml | 11 ++- src/loader/cmti.ml | 57 ++++++++++-- src/loader/ident_env.ml | 29 ++++++- src/loader/ident_env.mli | 2 + src/loader/implementation.ml | 4 +- src/loader/odoc_loader.ml | 53 +++++++++--- src/loader/typedtree_traverse.ml | 13 ++- src/model/compat.cppo.ml | 10 ++- src/model/lang.ml | 2 +- src/odoc/classify.cppo.ml | 50 +++++++++-- src/odoc/depends.ml | 19 ++-- src/odoc/dune | 24 ++++++ src/odoc/extract_code.cppo.ml | 7 +- src/syntax_highlighter/syntax_highlighter.ml | 44 +++++----- src/xref2/shape_tools.cppo.ml | 2 + test/xref2/lib/common.cppo.ml | 13 ++- test/xref2/lib/dune | 12 +++ 19 files changed, 349 insertions(+), 99 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 727de39c0c..93b8d1aa91 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -111,12 +111,17 @@ let read_label lbl = else match String.get lbl 0 with | '?' -> Some (Optional (String.sub lbl 1 (String.length lbl - 1))) | _ -> Some (Label lbl) -#else +#elif defined OXCAML match lbl with | Types.Nolabel -> None | Types.Labelled s -> Some (Label s) | Types.Optional s -> Some (Optional s) | Types.Position s -> (* FIXME: do better? *) Some (Label s) +#else + match lbl with + | Asttypes.Nolabel -> None + | Asttypes.Labelled s -> Some (Label s) + | Asttypes.Optional s -> Some (Optional s) #endif (* Handle type variable names *) @@ -162,7 +167,11 @@ let name_of_type_repr (ty : Compat.repr_type_node) = with Not_found -> let base = match ty.desc with +#if defined OXCAML | Tvar { name = Some name; _ } | Tunivar { name = Some name; _ } -> name +#else + | Tvar (Some name) | Tunivar (Some name) -> name +#endif | _ -> next_name () in let name = fresh_name base in @@ -192,7 +201,12 @@ let add_alias_proxy px = if not (List.memq px !aliased) then begin aliased := px :: !aliased; match px.desc with - | Tvar { name; _ } | Tunivar { name; _ } -> reserve_name name +#if defined OXCAML + | Tvar { name; _ } | Tunivar { name; _ } -> +#else + | Tvar name | Tunivar name -> +#endif + reserve_name name | _ -> () end @@ -235,7 +249,12 @@ let mark_type ty = if List.memq px visited && aliasable ty then add_alias_proxy px else let visited = px :: visited in match Compat.get_desc ty with - | Tvar { name; _ } -> reserve_name name +#if defined OXCAML + | Tvar { name; _ } | Tunivar { name; _ } -> +#else + | Tvar name | Tunivar name -> +#endif + reserve_name name | Tarrow(_, ty1, ty2, _) -> loop visited ty1; loop visited ty2 @@ -283,11 +302,6 @@ let mark_type ty = | Tpoly (ty, tyl) -> List.iter (fun t -> add_alias t) tyl; loop visited ty -#if defined OXCAML - | Tunivar { name; _ } -> reserve_name name -#else - | Tunivar name -> reserve_name name -#endif #if OCAML_VERSION>=(5,4,0) | Tpackage p -> List.iter (fun (_,x) -> loop visited x) p.pack_cstrs @@ -306,9 +320,9 @@ let mark_type ty = #if defined OXCAML | Tquote typ -> loop visited typ | Tsplice typ -> loop visited typ + | Tof_kind _ -> () #endif | Tlink _ -> assert false - | Tof_kind _ -> () in loop [] ty @@ -335,9 +349,11 @@ let mark_type_parameter param = let tvar_none ty = ty.desc <- Tvar None #elif OCAML_VERSION < (4,14,0) let tvar_none ty = Types.Private_type_expr.set_desc ty (Tvar None) -#else +#elif defined OXCAML let tvar_none ty jkind = Types.Transient_expr.(set_desc (coerce ty) (Tvar { name = None; jkind })) +#else +let tvar_none ty = Types.Transient_expr.(set_desc (coerce ty) (Tvar None)) #endif let wrap_constrained_params tyl = @@ -360,8 +376,13 @@ let prepare_type_parameters params manifest = let vars = Ctype.free_variables ty in List.iter (fun ty -> match Compat.get_desc ty with +#if defined OXCAML | Tvar { name = Some "_"; jkind } -> if List.memq ty vars then tvar_none ty jkind +#else + | Tvar (Some "_") -> + if List.memq ty vars then tvar_none ty +#endif | _ -> ()) params | None -> () @@ -374,7 +395,11 @@ let mark_constructor_args = List.iter mark_type #else function +#if defined OXCAML | Cstr_tuple args -> List.iter (fun carg -> mark_type carg.ca_type) args +#else + | Cstr_tuple args -> List.iter mark_type args +#endif | Cstr_record lds -> List.iter (fun ld -> mark_type ld.ld_type) lds #endif @@ -384,8 +409,10 @@ let mark_type_kind = function #else | Type_abstract -> () #endif -#if OCAML_VERSION >= (4,13,0) +#if defined OXCAML | Type_variant (cds,_,_) -> +#elif OCAML_VERSION >= (4,13,0) + | Type_variant (cds,_) -> #else | Type_variant cds -> #endif @@ -394,10 +421,14 @@ let mark_type_kind = function mark_constructor_args cd.cd_args; opt_iter mark_type cd.cd_res) cds - | Type_record(lds, _, _) -> - List.iter (fun ld -> mark_type ld.ld_type) lds +#if defined OXCAML | Type_record_unboxed_product(lds, _, _) -> List.iter (fun ld -> mark_type ld.ld_type) lds + | Type_record(lds, _, _) -> +#else + | Type_record(lds, _) -> +#endif + List.iter (fun ld -> mark_type ld.ld_type) lds | Type_open -> () let mark_type_declaration decl = @@ -479,7 +510,11 @@ let rec read_type_expr env typ = let name = name_of_type typ in if name = "_" then Any else Var name +#if defined OXCAML | Tarrow((lbl,_,_), arg, res, _) -> +#else + | Tarrow(lbl, arg, res, _) -> +#endif let lbl = read_label lbl in let lbl,arg = match lbl with @@ -557,9 +592,9 @@ let rec read_type_expr env typ = #if defined OXCAML | Tquote typ -> Quote (read_type_expr env typ) | Tsplice typ -> Splice (read_type_expr env typ) + | Tof_kind _ -> assert false #endif | Tlink _ -> assert false - | Tof_kind _ -> assert false in match alias with | None -> typ @@ -701,6 +736,12 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd = let source_loc_jane = None in Value { Value.id; source_loc; doc; type_; value ; source_loc_jane } +#if defined OXCAML +let is_mutable = Types.is_mutable +#else +let is_mutable ld = ld = Mutable +#endif + let read_label_declaration env parent ld = let open TypeDecl.Field in let name = Ident.name ld.ld_id in @@ -722,7 +763,11 @@ let read_constructor_declaration_arguments env parent arg = #else let open TypeDecl.Constructor in match arg with +#if defined OXCAML | Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg.ca_type) args) +#else + | Cstr_tuple args -> Tuple (List.map (read_type_expr env) args) +#endif | Cstr_record lds -> Record (List.map (read_label_declaration env parent) lds) #endif @@ -747,8 +792,10 @@ let read_type_kind env parent = | Type_abstract -> #endif None -#if OCAML_VERSION >= (4,13,0) +#if defined OXCAML | Type_variant (cstrs,_,_) -> +#elif OCAML_VERSION >= (4,13,0) + | Type_variant (cstrs,_) -> #else | Type_variant cstrs -> #endif @@ -756,14 +803,18 @@ let read_type_kind env parent = List.map (read_constructor_declaration env parent) cstrs in Some (Variant cstrs) - | Type_record(lbls, _, _) -> +#if defined OXCAML + | Type_record_unboxed_product(lbls, _, _) -> let lbls = List.map (read_label_declaration env (parent :> Identifier.FieldParent.t)) lbls in Some (Record lbls) - | Type_record_unboxed_product(lbls, _, _) -> + | Type_record(lbls, _, _) -> +#else + | Type_record(lbls, _) -> +#endif let lbls = List.map (read_label_declaration env (parent :> Identifier.FieldParent.t)) @@ -838,10 +889,14 @@ let read_type_declaration env parent id decl = decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private +#if defined OXCAML | Type_record_unboxed_product _ -> decl.type_private = Private -#if OCAML_VERSION >= (4,13,0) +#endif +#if defined OXCAML | Type_variant (tll,_,_) -> +#elif OCAML_VERSION >= (4,13,0) + | Type_variant (tll,_) -> #else | Type_variant tll -> #endif diff --git a/src/loader/cmi.mli b/src/loader/cmi.mli index 619d8493be..1d0cca0ac5 100644 --- a/src/loader/cmi.mli +++ b/src/loader/cmi.mli @@ -33,8 +33,10 @@ val read_interface : #if OCAML_VERSION < (4,3,0) val read_label : Asttypes.label -> Odoc_model.Lang.TypeExpr.label option -#else +#elif defined OXCAML val read_label : Types.arg_label -> Odoc_model.Lang.TypeExpr.label option +#else +val read_label : Asttypes.arg_label -> Odoc_model.Lang.TypeExpr.label option #endif val mark_type_expr : Types.type_expr -> unit @@ -94,4 +96,3 @@ val read_extension_constructor : env -> val read_exception : env -> Paths.Identifier.Signature.t -> Ident.t -> Types.extension_constructor -> Odoc_model.Lang.Exception.t - diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 4ea8c61ee6..16d811ba2c 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -590,13 +590,18 @@ and read_include env parent incl = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in let decl_modty = +#if defined OXCAML match unwrap_module_expr_desc incl.incl_mod.mod_desc, incl.incl_kind with - | Tmod_ident(p, _), Tincl_structure -> - let p = Env.Path.read_module env.ident_env p in - Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)) | _, (Tincl_functor _ | Tincl_gen_functor _) -> (* TODO: Handle [include functor] *) None + | Tmod_ident(p, _), Tincl_structure -> +#else + match unwrap_module_expr_desc incl.incl_mod.mod_desc with + | Tmod_ident(p, _) -> +#endif + let p = Env.Path.read_module env.ident_env p in + Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)) | _ -> let mty = read_module_expr env parent container incl.incl_mod in umty_of_mty mty diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index eeee68c4b8..85e1e72ad0 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -43,10 +43,15 @@ let read_label = Cmi.read_label let rec read_core_type env container ctyp = let open TypeExpr in match ctyp.ctyp_desc with +#if defined OXCAML (* TODO: presumably we want the layout in these first two cases, eventually *) | Ttyp_var (None, _layout) -> Any | Ttyp_var (Some s, _layout) -> Var s +#else + | Ttyp_any -> Any + | Ttyp_var s -> Var s +#endif | Ttyp_arrow(lbl, arg, res) -> let lbl = read_label lbl in #if OCAML_VERSION < (4,3,0) @@ -113,18 +118,24 @@ let rec read_core_type env container ctyp = let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_core_type env container) params in Class(p, params) - | Ttyp_alias(typ, var, _layout) -> +#if defined OXCAML + | Ttyp_alias(typ, var, _layout) -> ( (* TODO: presumably we want the layout, eventually *) +#else + | Ttyp_alias(typ, var) -> ( +#endif let typ = read_core_type env container typ in - begin match var with +#if defined OXCAML + match var with | None -> typ | Some var -> +#endif #if OCAML_VERSION >= (5,2,0) Alias(typ, var.txt) #else Alias(typ, var) #endif - end + ) | Ttyp_variant(fields, closed, present) -> let open TypeExpr.Polymorphic_variant in let elements = @@ -186,9 +197,9 @@ let rec read_core_type env container ctyp = #if defined OXCAML | Ttyp_quote typ -> Quote (read_core_type env container typ) | Ttyp_splice typ -> Splice (read_core_type env container typ) -#endif | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, []) | Ttyp_of_kind _ -> assert false +#endif let read_value_description env parent vd = let open Signature in @@ -210,10 +221,15 @@ let read_value_description env parent vd = let read_type_parameter (ctyp, var_and_injectivity) = let open TypeDecl in let desc = - (* TODO: presumably we want the layouts below, eventually *) match ctyp.ctyp_desc with +#if defined OXCAML + (* TODO: presumably we want the layouts below, eventually *) | Ttyp_var (None, _layout) -> Any | Ttyp_var (Some s, _layout) -> Var s +#else + | Ttyp_any -> Any + | Ttyp_var s -> Var s +#endif | _ -> assert false in let variance, injectivity = @@ -241,13 +257,19 @@ let read_type_parameter (ctyp, var_and_injectivity) = in {desc; variance; injectivity} +#if defined OXCAML +let is_mutable = Types.is_mutable +#else +let is_mutable ld = ld = Mutable +#endif + let read_label_declaration env parent label_parent ld = let open TypeDecl.Field in let open Odoc_model.Names in let name = Ident.name ld.ld_id in let id = Identifier.Mk.field(parent, FieldName.make_std name) in let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in - let mutable_ = Types.is_mutable ld.ld_mutable in + let mutable_ = is_mutable ld.ld_mutable in let type_ = read_core_type env label_parent ld.ld_type in {id; doc; mutable_; type_} @@ -257,7 +279,7 @@ let read_unboxed_label_declaration env parent label_parent ld = let name = Ident.name ld.ld_id in let id = Identifier.Mk.unboxed_field(parent, UnboxedFieldName.make_std name) in let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in - let mutable_ = Types.is_mutable ld.ld_mutable in + let mutable_ = is_mutable ld.ld_mutable in let type_ = read_core_type env label_parent ld.ld_type in {id; doc; mutable_; type_} @@ -269,7 +291,11 @@ let read_constructor_declaration_arguments env parent label_parent arg = #else match arg with | Cstr_tuple args -> +#if defined OXCAML Tuple (List.map (fun arg -> read_core_type env label_parent arg.ca_type) args) +#else + Tuple (List.map (fun arg -> read_core_type env label_parent arg) args) +#endif | Cstr_record lds -> Record (List.map (read_label_declaration env parent label_parent) lds) #endif @@ -299,12 +325,14 @@ let read_type_kind env parent = let lbls = List.map (read_label_declaration env parent label_parent) lbls in Some (Record lbls) +#if defined OXCAML | Ttype_record_unboxed_product lbls -> let parent = (parent :> Identifier.UnboxedFieldParent.t) in let label_parent = (parent :> Identifier.LabelParent.t) in let lbls = List.map (read_unboxed_label_declaration env parent label_parent) lbls in Some (Record_unboxed_product lbls) +#endif | Ttype_open -> Some Extensible let read_type_equation env container decl = @@ -447,7 +475,11 @@ let rec read_class_type_field env parent ctf = and read_self_type env container typ = match typ.ctyp_desc with +#if defined OXCAML | Ttyp_var (None, _) -> None +#else + | Ttyp_any -> None +#endif | _ -> Some (read_core_type env container typ) and read_class_signature env parent label_parent cltyp = @@ -646,6 +678,7 @@ and read_module_type env parent label_parent mty = in decl | Tmty_alias _ -> assert false +#if defined OXCAML | Tmty_strengthen (mty, path, _) -> let mty = read_module_type env parent label_parent mty in let s_path = Env.Path.read_module env.ident_env path in @@ -654,6 +687,7 @@ and read_module_type env parent label_parent mty = (* We always strengthen with aliases *) Strengthen {s_expr; s_path; s_aliasable = true; s_expansion = None} | None -> failwith "invalid Tmty_strengthen" +#endif (** Like [read_module_type] but handle the canonical tag in the top-comment. If [canonical] is [Some _], no tag is expected in the top-comment. *) @@ -783,7 +817,11 @@ and read_signature_item env parent item = [ Open (read_open env parent o) ] +#if defined OXCAML | Tsig_include (incl, _) -> +#else + | Tsig_include incl -> +#endif read_include env parent incl | Tsig_class cls -> read_class_descriptions env parent cls @@ -839,8 +877,13 @@ and read_include env parent incl = let expr = read_module_type env parent container incl.incl_mod in let umty = Odoc_model.Lang.umty_of_mty expr in let expansion = { content; shadowed; } in +#if defined OXCAML match umty, incl.incl_kind with | Some uexpr, Tincl_structure -> +#else + match umty with + | Some uexpr -> +#endif let decl = Include.ModuleType uexpr in [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] | _ -> diff --git a/src/loader/ident_env.ml b/src/loader/ident_env.ml index 1dd570d018..54788364af 100644 --- a/src/loader/ident_env.ml +++ b/src/loader/ident_env.ml @@ -118,12 +118,18 @@ and extract_signature_type_items_extract vis ~hidden item rest = #else | Types.Type_abstract _ -> [] #endif +#if defined OXCAML | Type_record (_, _, _) -> [] | Type_record_unboxed_product (_, _, _) -> [] +#else + | Type_record (_, _) -> [] +#endif #if OCAML_VERSION < (4,13,0) | Type_variant cstrs -> -#else +#elif defined OXCAML | Type_variant (cstrs, _, _) -> +#else + | Type_variant (cstrs, _) -> #endif List.map (fun c -> `Constructor (c.Types.cd_id, id, Some c.cd_loc)) cstrs | Type_open -> [] in @@ -211,7 +217,9 @@ let rec extract_signature_tree_items : bool -> Typedtree.signature_item list -> Ttype_abstract -> [] | Ttype_variant constrs -> List.map (fun c -> `Constructor (c.cd_id, decl.typ_id, Some c.cd_loc)) constrs | Ttype_record _ -> [] +#if defined OXCAML | Ttype_record_unboxed_product _ -> [] +#endif | Ttype_open -> [] ) decls @ extract_signature_tree_items hide_item rest @@ -251,7 +259,11 @@ let rec extract_signature_tree_items : bool -> Typedtree.signature_item list -> [`Value (val_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest | { sig_desc = Tsig_modtype mtd; sig_loc; _} :: rest -> [`ModuleType (mtd.mtd_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest +#if defined OXCAML | {sig_desc = Tsig_include (incl, _); _ } :: rest -> +#else + | {sig_desc = Tsig_include incl; _ } :: rest -> +#endif [`Include (extract_signature_type_items Exported (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest | {sig_desc = Tsig_attribute attr; _ } :: rest -> let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in @@ -307,7 +319,7 @@ let rec read_pattern hide_item pat = #elif defined OXCAML | Tpat_var(id, loc, _, _, _) -> #else - | Tpat_var(id, loc, _, _) -> + | Tpat_var(id, loc, _) -> #endif [`Value(id, hide_item, Some loc.loc)] #if OCAML_VERSION < (5,2,0) @@ -322,8 +334,10 @@ let rec read_pattern hide_item pat = `Value(id, hide_item, Some loc.loc) :: read_pattern hide_item pat | Tpat_record(pats, _) -> List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats) +#if defined OXCAML | Tpat_record_unboxed_product(pats, _) -> List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats) +#endif #if OCAML_VERSION < (4,13,0) | Tpat_construct(_, _, pats) #else @@ -371,7 +385,9 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list -> Ttype_abstract -> [] | Ttype_variant constrs -> List.map (fun c -> `Constructor (c.cd_id, decl.typ_id, Some c.cd_loc)) constrs | Ttype_record _ -> [] +#if defined OXCAML | Ttype_record_unboxed_product _ -> [] +#endif | Ttype_open -> [] )) decls @ extract_structure_tree_items hide_item rest @@ -693,13 +709,20 @@ let find_class_identifier env id = let find_class_type_identifier env id = Ident.find_same id env.class_types +let ident_is_global_or_predef id = +#if defined OXCAML + Ident.is_global_or_predef id +#else + Ident.persistent id +#endif + let is_shadowed env id = List.mem id env.shadowed module Path = struct let read_module_ident env id = - if Ident.is_global_or_predef id then `Root (ModuleName.of_ident id) + if ident_is_global_or_predef id then `Root (ModuleName.of_ident id) else try find_module env id with Not_found -> assert false diff --git a/src/loader/ident_env.mli b/src/loader/ident_env.mli index 337f9ffafe..531ceb6261 100644 --- a/src/loader/ident_env.mli +++ b/src/loader/ident_env.mli @@ -67,6 +67,8 @@ val find_type_identifier : t -> Ident.t -> Paths.Identifier.Type.t val find_class_identifier : t -> Ident.t -> Paths.Identifier.Class.t +val ident_is_global_or_predef : Ident.t -> bool + val is_shadowed : t -> Ident.t -> bool val find_class_type_identifier : t -> Ident.t -> Paths.Identifier.ClassType.t diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index d7c699ba96..d3924a67b7 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -1,7 +1,7 @@ #if OCAML_VERSION >= (4, 14, 0) let rec is_persistent : Path.t -> bool = function - | Path.Pident id -> Ident.is_global_or_predef id + | Path.Pident id -> Ident_env.ident_is_global_or_predef id | Path.Pdot(p, _) -> is_persistent p | Path.Papply(p, _) -> is_persistent p #if OCAML_VERSION >= (5,1,0) @@ -79,7 +79,9 @@ module Env = struct | Tmty_signature sg -> signature env (parent : Identifier.Signature.t) sg | Tmty_with (mty, _) -> module_type env parent mty | Tmty_functor (_, t) -> module_type env parent t +#if defined OXCAML | Tmty_strengthen (t, _, _) -> module_type env parent t +#endif | Tmty_ident _ | Tmty_alias _ | Tmty_typeof _ -> () and module_bindings env parent mbs = List.iter (module_binding env parent) mbs diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index 95415b2927..0ad0d28941 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -108,6 +108,14 @@ let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id ?canonical content +#if defined OXCAML +let unit_name_as_string = Compilation_unit.name_as_string +let name_to_string = Compilation_unit.Name.to_string +#else +let unit_name_as_string x = x +let name_to_string x = x +#endif + let read_cmti ~make_root ~parent ~filename ~warnings_tag () = let cmt_info = Cmt_format.read_cmt filename in match cmt_info.cmt_annots with @@ -119,7 +127,7 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = try Odoc_model.Names.set_unique_ident (Digest.to_hex digest) with _ -> () in - let name = cmt_info.cmt_modname |> Compilation_unit.name_as_string in + let name = cmt_info.cmt_modname |> unit_name_as_string in let sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, @@ -129,6 +137,7 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = let id, sg, canonical = Cmti.read_interface parent name ~warnings_tag intf in +#if defined OXCAML let imports = cmt_info.cmt_imports |> Array.map (fun import -> @@ -136,6 +145,9 @@ let read_cmti ~make_root ~parent ~filename ~warnings_tag () = Import_info.crc import) |> Array.to_list in +#else + let imports = cmt_info.cmt_imports in +#endif compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile ~name ~id ?canonical sg) | _ -> raise Not_an_interface @@ -145,7 +157,7 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = | exception Cmi_format.Error (Not_an_interface _) -> raise Not_an_implementation | cmt_info -> ( - let name = cmt_info.cmt_modname |> Compilation_unit.name_as_string in + let name = cmt_info.cmt_modname |> unit_name_as_string in let sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, @@ -162,6 +174,7 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = | Some digest -> ( try Odoc_model.Names.set_unique_ident (Digest.to_hex digest) with _ -> ())); +#if defined OXCAML let imports = cmt_info.cmt_imports |> Array.map (fun import -> @@ -169,6 +182,9 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = Import_info.crc import) |> Array.to_list in +#else + let imports = cmt_info.cmt_imports in +#endif match cmt_info.cmt_annots with | Packed (_, files) -> let id = @@ -207,27 +223,36 @@ let read_cmt ~make_root ~parent ~filename ~warnings_tag () = ~name ~id ?canonical sg | _ -> raise Not_an_implementation) +#if defined OXCAML let compilation_unit_of_import_info (info : Import_info.Intf.Nonalias.t option) = match info with | None -> None | Some (Parameter, _) -> None | Some (Normal cu, _) -> Some (cu |> Compilation_unit.full_path_as_string) +#else +let compilation_unit_of_import_info info = + Option.map snd info +#endif + +#if defined OXCAML +let cmi_crcs cmi_info = + List.map (fun import -> Import_info.name import, Import_info.Intf.info import) + (Array.to_list cmi_info.Cmi_format.cmi_crcs) +#else +let cmi_crcs cmi_info = cmi_info.Cmi_format.cmi_crcs +#endif let read_cmi ~make_root ~parent ~filename ~warnings_tag () = let cmi_info = Cmi_format.read_cmi filename in - let cmi_crcs = - List.map (fun import -> - Import_info.name import, Import_info.Intf.info import) - (Array.to_list cmi_info.cmi_crcs) - in + let cmi_crcs = cmi_crcs cmi_info in match cmi_crcs with - | (name, (Some _ as interface)) :: imports - when name = cmi_info.cmi_name -> - let name = name |> Compilation_unit.Name.to_string in + | (name, (Some _ as interface)) :: imports when name = cmi_info.cmi_name -> + let name = name |> name_to_string in let id, sg = Cmi.read_interface parent name ~warnings_tag (Odoc_model.Compat.signature cmi_info.cmi_sign) in +#if defined OXCAML let imports = imports |> List.map (fun (name, info_opt) -> @@ -235,6 +260,7 @@ let read_cmi ~make_root ~parent ~filename ~warnings_tag () = compilation_unit_of_import_info info_opt) in let interface = interface |> Option.map snd in +#endif compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id sg | _ -> raise Corrupted @@ -243,20 +269,23 @@ let read_impl ~make_root ~filename ~source_id () = | exception Cmi_format.Error (Not_an_interface _) -> raise Not_an_implementation | cmt_info -> ( - let name = cmt_info.cmt_modname |> Compilation_unit.name_as_string in + let name = cmt_info.cmt_modname |> unit_name_as_string in let _sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, cmt_info.cmt_builddir ) in let interface = cmt_info.cmt_interface_digest in + let imports = cmt_info.cmt_imports in +#if defined OXCAML let imports = - cmt_info.cmt_imports + imports |> Array.map (fun import -> Import_info.name import |> Compilation_unit.Name.to_string, Import_info.crc import) |> Array.to_list in +#endif match cmt_info.cmt_annots with | Implementation _impl -> let digest = diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index ab501d3b4d..abd5eeab9d 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -13,7 +13,12 @@ module Analysis = struct if exp_loc.loc_ghost then () else match expr.exp_desc with - | Texp_ident (p, _, _, _, _) -> poses := (Value p, exp_loc) :: !poses +#if defined OXCAML + | Texp_ident (p, _, _, _, _) -> +#else + | Texp_ident (p, _, _) -> +#endif + poses := (Value p, exp_loc) :: !poses | _ -> () let pat env (type a) poses : a Typedtree.general_pattern -> unit = function @@ -25,10 +30,12 @@ module Analysis = struct in let () = match pat_desc with -#if OCAML_VERSION >= (5, 2, 0) +#if defined OXCAML | Tpat_var (id, loc, _uid, _, _) -> ( +#elif OCAML_VERSION >= (5, 2, 0) + | Tpat_var (id, loc, _uid) -> ( #else - | Tpat_var (id, loc, _, _) -> ( + | Tpat_var (id, loc) -> ( #endif match maybe_localvalue id loc.loc with | Some x -> poses := x :: !poses diff --git a/src/model/compat.cppo.ml b/src/model/compat.cppo.ml index 1cbf928e5d..05733302cd 100644 --- a/src/model/compat.cppo.ml +++ b/src/model/compat.cppo.ml @@ -93,18 +93,20 @@ and visibility : Types.visibility -> visibility = function | Types.Hidden -> Hidden | Types.Exported -> Exported -and aliasability : Types.Aliasability.t -> Aliasability.t = function - | Types.Aliasability.Not_aliasable -> Aliasability.Not_aliasable - | Types.Aliasability.Aliasable -> Aliasability.Aliasable - and module_type : Types.module_type -> module_type = function | Types.Mty_ident p -> Mty_ident p | Types.Mty_signature s -> Mty_signature (signature s) | Types.Mty_functor (a, b) -> Mty_functor(functor_parameter a, module_type b) | Types.Mty_alias p -> Mty_alias p +#if defined OXCAML | Types.Mty_strengthen (mty,p,a) -> Mty_strengthen (module_type mty, p, aliasability a) +and aliasability : Types.Aliasability.t -> Aliasability.t = function + | Types.Aliasability.Not_aliasable -> Aliasability.Not_aliasable + | Types.Aliasability.Aliasable -> Aliasability.Aliasable +#endif + and functor_parameter : Types.functor_parameter -> functor_parameter = function | Types.Unit -> Unit | Types.Named (a,b) -> Named (a, module_type b) diff --git a/src/model/lang.ml b/src/model/lang.ml index 300fee5eba..41b7c6ba3f 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -21,7 +21,7 @@ module Source_loc_jane = struct let of_location (build_dir : string) (loc: Location.t) = let { Location.loc_start ; _ } = loc in - let { pos_fname ; pos_lnum ; _ } = loc_start in + let { Lexing.pos_fname ; pos_lnum ; _ } = loc_start in { filename = build_dir ^ "/" ^ pos_fname ; line_number = pos_lnum } end diff --git a/src/odoc/classify.cppo.ml b/src/odoc/classify.cppo.ml index 2defa8f329..367b006fb7 100644 --- a/src/odoc/classify.cppo.ml +++ b/src/odoc/classify.cppo.ml @@ -15,8 +15,17 @@ let debug = ref false let log fmt = if !debug then Format.printf fmt else Format.ifprintf Format.std_formatter fmt -let name_of_import import = - Import_info.name import |> Compilation_unit.Name.to_string +#if defined OXCAML +let name_of_import import = Import_info.name import |> Compilation_unit.Name.to_string +let intf_info import = Option.map snd (Import_info.Intf.info import) +let cmt_imports cmt_infos = Array.to_list cmt_infos.Cmt_format.cmt_imports +let cmi_crcs cmi_infos = Array.to_list cmi_infos.Cmi_format.cmi_crcs +#else +let name_of_import (cu, _) = cu +let intf_info (_, info) = info +let cmt_imports cmt_infos = cmt_infos.Cmt_format.cmt_imports +let cmi_crcs cmi_infos = cmi_infos.Cmi_format.cmi_crcs +#endif module Archive = struct type name = string @@ -42,6 +51,12 @@ module Archive = struct impl_deps = StringSet.diff s.impl_deps s.modules; } +#if defined OXCAML + let cu_imports cu = Array.to_list cu.cu_imports +#else + let cu_imports cu = cu.cu_imports +#endif + let add_cu lib cu = normalise { @@ -49,9 +64,9 @@ module Archive = struct modules = StringSet.add (Odoc_model.Compat.compunit_name cu.cu_name) lib.modules; intf_deps = - Array.fold_left + List.fold_left (fun deps import -> StringSet.add (name_of_import import) deps) - lib.intf_deps cu.cu_imports; + lib.intf_deps (cu_imports cu); impl_deps = List.fold_left (fun deps id -> StringSet.add id deps) @@ -60,7 +75,12 @@ module Archive = struct } let add_unit_info lib (unit, cmis, cmxs) = - let name = unit |> Compilation_unit.name_as_string in + let name = + unit +#if defined OXCAML + |> Compilation_unit.name_as_string +#endif + in normalise { lib with @@ -100,7 +120,9 @@ module Cmi = struct let get_deps filename = let cmi, _cmt = Cmt_format.read filename in match cmi with - | Some cmi -> Array.map name_of_import cmi.Cmi_format.cmi_crcs |> Array.to_seq |> StringSet.of_seq + | Some cmi -> + let cmi_crcs = cmi_crcs cmi in + List.map name_of_import cmi_crcs |> StringSet.of_list | None -> StringSet.empty end @@ -170,6 +192,7 @@ let read_cma ic init = let read_cmxa ic init = let li = (input_value ic : Cmx_format.library_infos) in close_in ic; +#if defined OXCAML (* FIXME: This OxCaml-specific code is awful and can be gotten rid of once this PR (which was inspired by having to write this very code) is merged: https://github.com/oxcaml/oxcaml/pull/2673 *) @@ -188,8 +211,16 @@ let read_cmxa ic init = unit.li_name, cmis, cmxs) li.lib_units in +#else + let units = + List.map + (fun (u, _) -> u.Cmx_format.ui_name, u.ui_imports_cmi, u.ui_imports_cmx) + li.lib_units + in +#endif Ok (List.fold_left Archive.add_unit_info init units) + #if OCAML_VERSION >= (4, 12, 0) open Misc @@ -197,7 +228,12 @@ let read_library ic init = let open Magic_number in match read_current_info ~expected_kind:None ic with | Ok { kind = Cma; version = _ } -> read_cma ic init - | Ok { kind = Cmxa; version = _ } -> read_cmxa ic init +#if defined OXCAML + | Ok { kind = Cmxa; version = _ } -> +#else + | Ok { kind = Cmxa _; version = _ } -> +#endif + read_cmxa ic init | Ok { kind = _; version = _ } -> Error (`Msg "Not a valid library") | Error _ -> Error (`Msg "Not a valid file") #else diff --git a/src/odoc/depends.ml b/src/odoc/depends.ml index 87e9c56765..fe72206811 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -35,25 +35,20 @@ end module Compile_set = Set.Make (Compile) -let add_dep0 acc (unit_name, crc_with_unit) = - match unit_name, crc_with_unit with - | _, None -> acc (* drop module aliases *) - | unit_name, Some (_unit, digest) -> - let unit_name = unit_name |> Compilation_unit.Name.to_string in - Compile_set.add { Compile.unit_name; digest } acc - let add_dep acc import = - let unit_name = Import_info.name import in - let crc_with_unit = Import_info.Intf.info import in - add_dep0 acc (unit_name, crc_with_unit) + let unit_name = Classify.name_of_import import in + let crc_with_unit = Classify.intf_info import in + match (unit_name, crc_with_unit) with + | _, None -> acc + | unit_name, Some digest -> Compile_set.add { Compile.unit_name; digest } acc let for_compile_step_cmt acc file = let cmt_infos = Cmt_format.read_cmt (Fs.File.to_string file) in - Array.fold_left ~f:add_dep ~init:acc cmt_infos.Cmt_format.cmt_imports + List.fold_left ~f:add_dep ~init:acc (Classify.cmt_imports cmt_infos) let for_compile_step_cmi_or_cmti acc file = let cmi_infos = Cmi_format.read_cmi (Fs.File.to_string file) in - Array.fold_left ~f:add_dep ~init:acc cmi_infos.Cmi_format.cmi_crcs + List.fold_left ~f:add_dep ~init:acc (Classify.cmi_crcs cmi_infos) let for_compile_step files = let set = diff --git a/src/odoc/dune b/src/odoc/dune index 40e4ab208f..ee59e3b47b 100644 --- a/src/odoc/dune +++ b/src/odoc/dune @@ -25,19 +25,43 @@ (targets classify.ml) (deps (:x classify.cppo.ml)) + (enabled_if + (not %{ocaml-config:ox})) (action (chdir %{workspace_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) +(rule + (targets classify.ml) + (deps + (:x classify.cppo.ml)) + (enabled_if %{ocaml-config:ox}) + (action + (chdir + %{workspace_root} + (run %{bin:cppo} -V OCAML:%{ocaml_version} -D OXCAML %{x} -o %{targets})))) + (rule (targets extract_code.ml) (deps (:x extract_code.cppo.ml)) + (enabled_if + (not %{ocaml-config:ox})) (action (chdir %{workspace_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) +(rule + (targets extract_code.ml) + (deps + (:x extract_code.cppo.ml)) + (enabled_if %{ocaml-config:ox}) + (action + (chdir + %{workspace_root} + (run %{bin:cppo} -V OCAML:%{ocaml_version} -D OXCAML %{x} -o %{targets})))) + (documentation (package odoc)) diff --git a/src/odoc/extract_code.cppo.ml b/src/odoc/extract_code.cppo.ml index 2ceb076a89..a31282f1d8 100644 --- a/src/odoc/extract_code.cppo.ml +++ b/src/odoc/extract_code.cppo.ml @@ -88,7 +88,12 @@ let iterator line_directives oc names = let signature_item sub sig_ = match sig_.Typedtree.sig_desc with | Tsig_attribute attr -> attribute sub attr - | Tsig_include (incl, _) -> attributes sub incl.incl_attributes +#if defined OXCAML + | Tsig_include (incl, _) -> +#else + | Tsig_include incl -> +#endif + attributes sub incl.incl_attributes | Tsig_open o -> attributes sub o.open_attributes | _ -> default_iterator.signature_item sub sig_ in diff --git a/src/syntax_highlighter/syntax_highlighter.ml b/src/syntax_highlighter/syntax_highlighter.ml index d2ca418393..d8c3b5a18c 100644 --- a/src/syntax_highlighter/syntax_highlighter.ml +++ b/src/syntax_highlighter/syntax_highlighter.ml @@ -7,8 +7,6 @@ let tag_of_token (tok : Parser.token) = | AND -> "AND" | AS -> "AS" | ASSERT -> "ASSERT" - | AT -> "AT" - | ATAT -> "ATAT" | BACKQUOTE -> "BACKQUOTE" | BANG -> "BANG" | BAR -> "BAR" @@ -21,7 +19,6 @@ let tag_of_token (tok : Parser.token) = | COLONCOLON -> "COLONCOLON" | COLONEQUAL -> "COLONEQUAL" | COLONGREATER -> "COLONGREATER" - | COLONRBRACKET -> "COLONRBRACKET" | COMMA -> "COMMA" | COMMENT _ -> "COMMENT" | CONSTRAINT -> "CONSTRAINT" @@ -30,7 +27,6 @@ let tag_of_token (tok : Parser.token) = | DONE -> "DONE" | DOT -> "DOT" | DOTDOT -> "DOTDOT" - | DOTHASH -> "DOTHASH" | DOWNTO -> "DOWNTO" | ELSE -> "ELSE" | END -> "END" @@ -38,7 +34,6 @@ let tag_of_token (tok : Parser.token) = | EOL -> "EOL" | EQUAL -> "EQUAL" | EXCEPTION -> "EXCEPTION" - | EXCLAVE -> "EXCLAVE" | EXTERNAL -> "EXTERNAL" | FALSE -> "FALSE" | FLOAT _ -> "FLOAT" @@ -46,15 +41,9 @@ let tag_of_token (tok : Parser.token) = | FUN -> "FUN" | FUNCTION -> "FUNCTION" | FUNCTOR -> "FUNCTOR" - | GLOBAL -> "GLOBAL" | GREATER -> "GREATER" | GREATERRBRACE -> "GREATERRBRACE" | GREATERRBRACKET -> "GREATERRBRACKET" - | HASH_FLOAT _ -> "HASH_FLOAT" - | HASH_INT _ -> "HASH_INT" - | HASH_SUFFIX -> "HASH_SUFFIX" - | HASHLBRACE -> "HASHLBRACE" - | HASHLPAREN -> "HASHLPAREN" | IF -> "IF" | IN -> "IN" | INCLUDE -> "INCLUDE" @@ -66,8 +55,6 @@ let tag_of_token (tok : Parser.token) = | INHERIT -> "INHERIT" | INITIALIZER -> "INITIALIZER" | INT _ -> "INT" - | KIND_ABBREV -> "KIND_ABBREV" - | KIND_OF -> "KIND_OF" | LABEL _ -> "LABEL" | LAZY -> "LAZY" | LBRACE -> "LBRACE" @@ -77,7 +64,6 @@ let tag_of_token (tok : Parser.token) = | LBRACKETATAT -> "LBRACKETATAT" | LBRACKETATATAT -> "LBRACKETATATAT" | LBRACKETBAR -> "LBRACKETBAR" - | LBRACKETCOLON -> "LBRACKETCOLON" | LBRACKETGREATER -> "LBRACKETGREATER" | LBRACKETLESS -> "LBRACKETLESS" | LBRACKETPERCENT -> "LBRACKETPERCENT" @@ -87,25 +73,21 @@ let tag_of_token (tok : Parser.token) = | LET -> "LET" | LIDENT "failwith" -> "failwith" | LIDENT _ -> "LIDENT" - | LOCAL -> "LOCAL" | LPAREN -> "LPAREN" | MATCH -> "MATCH" | METHOD -> "METHOD" | MINUS -> "MINUS" | MINUSDOT -> "MINUSDOT" | MINUSGREATER -> "MINUSGREATER" - | MOD -> "MOD" | MODULE -> "MODULE" | MUTABLE -> "MUTABLE" | NEW -> "NEW" | NONREC -> "NONREC" | OBJECT -> "OBJECT" | OF -> "OF" - | ONCE -> "ONCE" | OPEN -> "OPEN" | OPTLABEL _ -> "OPTLABEL" | OR -> "OR" - | OVERWRITE -> "OVERWRITE" | PERCENT -> "PERCENT" | PLUS -> "PLUS" | PLUSDOT -> "PLUSDOT" @@ -121,7 +103,6 @@ let tag_of_token (tok : Parser.token) = | SEMI -> "SEMI" | SEMISEMI -> "SEMISEMI" | SIG -> "SIG" - | STACK -> "STACK" | STAR -> "STAR" | STRING _ -> "STRING" | STRUCT -> "STRUCT" @@ -133,7 +114,6 @@ let tag_of_token (tok : Parser.token) = | TYPE -> "TYPE" | UIDENT _ -> "UIDENT" | UNDERSCORE -> "UNDERSCORE" - | UNIQUE -> "UNIQUE" | VAL -> "VAL" | VIRTUAL -> "VIRTUAL" | WHEN -> "WHEN" @@ -166,10 +146,30 @@ let tag_of_token (tok : Parser.token) = | LETOP _ -> "LETOP" #endif #if defined OXCAML - | RBRACKETGREATER -> "RBRACKETGREATER" - | LESSLBRACKET -> "LESSLBRACKET" + | AT -> "AT" + | ATAT -> "ATAT" + | COLONRBRACKET -> "COLONRBRACKET" | DOLLAR -> "DOLLAR" + | DOTHASH -> "DOTHASH" + | EXCLAVE -> "EXCLAVE" + | GLOBAL -> "GLOBAL" + | HASHLBRACE -> "HASHLBRACE" + | HASHLPAREN -> "HASHLPAREN" | HASH_CHAR _ -> "HASH_CHAR" + | HASH_FLOAT _ -> "HASH_FLOAT" + | HASH_INT _ -> "HASH_INT" + | HASH_SUFFIX -> "HASH_SUFFIX" + | KIND_ABBREV -> "KIND_ABBREV" + | KIND_OF -> "KIND_OF" + | LBRACKETCOLON -> "LBRACKETCOLON" + | LESSLBRACKET -> "LESSLBRACKET" + | LOCAL -> "LOCAL" + | MOD -> "MOD" + | ONCE -> "ONCE" + | OVERWRITE -> "OVERWRITE" + | RBRACKETGREATER -> "RBRACKETGREATER" + | STACK -> "STACK" + | UNIQUE -> "UNIQUE" #endif #if OCAML_VERSION >= (5,3,0) | METAOCAML_ESCAPE -> "METAOCAML_ESCAPE" diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index ff5d9a9f6f..e32fa997cc 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -118,7 +118,9 @@ let unit_of_uid uid = | Item { comp_unit; _ } -> Some comp_unit | Predef _ -> None | Internal -> None +#if defined OXCAML | Unboxed_version _ -> None +#endif #if OCAML_VERSION >= (5,2,0) let rec traverse_aliases = function diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index d731d020c5..e6d128c491 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -18,8 +18,10 @@ utop # Resolve.signature Env.empty sg let _ = Toploop.set_paths () +#if defined OXCAML let dummy_compilation_unit = Compilation_unit.of_string "" let dummy_unit_info = Unit_info.make_dummy ~input_name:"" dummy_compilation_unit +#endif let cmti_of_string s = Odoc_xref2.Tools.reset_caches (); @@ -29,19 +31,24 @@ let cmti_of_string s = Typemod.type_interface #if OCAML_VERSION >= (4,4,0) && OCAML_VERSION < (4,9,0) "" -#endif +#elif defined OXCAML ~sourcefile:"" dummy_compilation_unit +#endif env p;; let cmt_of_string s = let env = Compmisc.initial_env () in let l = Lexing.from_string s in let p = Parse.implementation l in -#if OCAML_VERSION < (5,2,0) +#if defined OXCAML + Typemod.type_implementation dummy_unit_info dummy_compilation_unit env p +#elif OCAML_VERSION < (5,2,0) Typemod.type_implementation "" "" "" env p +#elif OCAML_VERSION < (5,3,0) + Typemod.type_implementation (Unit_info.make ~source_file:"" "") env p #else - Typemod.type_implementation dummy_unit_info dummy_compilation_unit env p + Typemod.type_implementation Unit_info.(make ~source_file:"" Impl "") env p #endif let parent = Odoc_model.Paths.Identifier.Mk.page (None, PageName.make_std "None") diff --git a/test/xref2/lib/dune b/test/xref2/lib/dune index f4a4a45781..db250b20fa 100644 --- a/test/xref2/lib/dune +++ b/test/xref2/lib/dune @@ -2,11 +2,23 @@ (targets common.ml) (deps (:x common.cppo.ml)) + (enabled_if + (not %{ocaml-config:ox})) (action (chdir %{workspace_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) +(rule + (targets common.ml) + (deps + (:x common.cppo.ml)) + (enabled_if %{ocaml-config:ox}) + (action + (chdir + %{workspace_root} + (run %{bin:cppo} -V OCAML:%{ocaml_version} -D "OXCAML" %{x} -o %{targets})))) + (library (name odoc_xref_test) (public_name odoc.xref_test)