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/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/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 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 7a99172f09..ee3792868b 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 = @@ -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,21 +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 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)) - 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 @@ -476,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 " " @@ -515,6 +522,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 : @@ -566,6 +575,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 -> @@ -886,6 +935,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 @@ -1417,11 +1467,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 +1612,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 +1630,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 +1653,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 +1665,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 +1706,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 @@ -1831,4 +1896,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/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/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 b81b6ca9f6..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 @@ -64,8 +65,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..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 @@ -62,10 +63,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 f7e693dfc2..30350eddb7 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,20 @@ 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_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 = @@ -94,10 +110,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 +125,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 +235,24 @@ 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 (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 } ] -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 source_loc f = + let entry = Entry.of_field type_id params source_loc f in [ Tree.leaf entry ] -and field type_id params f = - let entry = Entry.of_field type_id params f in +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 = @@ -263,7 +289,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 = @@ -282,9 +308,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 @@ -310,5 +338,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 53bbc7ac3b..93b8d1aa91 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -60,7 +60,7 @@ 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]) #else let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [ty]) @@ -86,7 +86,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 @@ -111,6 +111,12 @@ let read_label lbl = else match String.get lbl 0 with | '?' -> Some (Optional (String.sub lbl 1 (String.length lbl - 1))) | _ -> Some (Label lbl) +#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 @@ -161,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 @@ -191,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 @@ -234,14 +249,22 @@ 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 -#if OCAML_VERSION >= (5,4,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 defined OXCAML + | Tunboxed_tuple tyl -> List.iter (fun (_, ty) -> loop visited ty) tyl #endif | Tconstr(_, tyl, _) -> List.iter (loop visited) tyl @@ -279,7 +302,6 @@ let mark_type ty = | Tpoly (ty, tyl) -> List.iter (fun t -> add_alias t) tyl; loop visited ty - | Tunivar name -> reserve_name name #if OCAML_VERSION>=(5,4,0) | Tpackage p -> List.iter (fun (_,x) -> loop visited x) p.pack_cstrs @@ -294,6 +316,11 @@ let mark_type ty = | Tsubst ty -> loop visited ty #else | Tsubst (ty,_) -> loop visited ty +#endif +#if defined OXCAML + | Tquote typ -> loop visited typ + | Tsplice typ -> loop visited typ + | Tof_kind _ -> () #endif | Tlink _ -> assert false in @@ -322,6 +349,9 @@ 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) +#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 @@ -346,7 +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 - | Tvar (Some "_") -> if List.memq ty vars then tvar_none ty +#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 -> () @@ -359,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 @@ -369,7 +409,9 @@ 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 -> @@ -379,7 +421,13 @@ let mark_type_kind = function mark_constructor_args cd.cd_args; opt_iter mark_type cd.cd_res) cds +#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 -> () @@ -462,28 +510,44 @@ 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 | 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 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) || 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 defined OXCAML + | 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 @@ -524,6 +588,11 @@ let rec read_type_expr env typ = | Tsubst typ -> read_type_expr env typ #else | Tsubst (typ,_) -> read_type_expr env typ +#endif +#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 in @@ -649,7 +718,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 defined OXCAML + | Val_reg _ -> Value.Abstract +#else | Val_reg -> Value.Abstract +#endif | Val_prim desc -> let primitives = let open Primitive in @@ -659,7 +732,15 @@ 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 } + +#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 @@ -669,7 +750,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_} @@ -682,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 @@ -707,7 +792,9 @@ 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 -> @@ -716,7 +803,18 @@ let read_type_kind env parent = List.map (read_constructor_declaration env parent) cstrs in Some (Variant cstrs) +#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(lbls, _, _) -> +#else | Type_record(lbls, _) -> +#endif let lbls = List.map (read_label_declaration env (parent :> Identifier.FieldParent.t)) @@ -791,7 +889,13 @@ let read_type_declaration env parent id decl = decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private -#if OCAML_VERSION >= (4,13,0) +#if defined OXCAML + | Type_record_unboxed_product _ -> + decl.type_private = Private +#endif +#if defined OXCAML + | Type_variant (tll,_,_) -> +#elif OCAML_VERSION >= (4,13,0) | Type_variant (tll,_) -> #else | Type_variant tll -> @@ -806,7 +910,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 @@ -853,7 +959,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 @@ -868,7 +976,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_} @@ -951,7 +1059,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 @@ -989,7 +1099,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 @@ -1015,6 +1127,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 @@ -1024,7 +1147,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 @@ -1043,7 +1168,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/cmi.mli b/src/loader/cmi.mli index 6075c8f4de..1d0cca0ac5 100644 --- a/src/loader/cmi.mli +++ b/src/loader/cmi.mli @@ -33,6 +33,8 @@ val read_interface : #if OCAML_VERSION < (4,3,0) val read_label : Asttypes.label -> Odoc_model.Lang.TypeExpr.label option +#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 @@ -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 3f5cf998bf..16d811ba2c 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 @@ -41,17 +43,22 @@ let rec read_pattern env parent doc pat = | Tpat_any -> [] #if OCAML_VERSION < (5,2,0) | Tpat_var(id, _) -> +#elif defined OXCAML + | Tpat_var(id, _, _uid, _, _) -> #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 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 defined OXCAML + | Tpat_alias(pat, id, _, _, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, _,_) -> #else @@ -62,13 +69,18 @@ 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) +#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 defined OXCAML + | 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 @@ -83,7 +95,14 @@ 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 defined OXCAML + | 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 -> #else | Tpat_array (_, pats) -> @@ -361,7 +380,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 @@ -481,7 +501,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) @@ -569,8 +590,16 @@ 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 + | _, (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)) | _ -> 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.ml b/src/loader/cmti.ml index ba44f115ad..85e1e72ad0 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 @@ -42,8 +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) @@ -64,12 +72,17 @@ 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) || 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 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 +#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 @@ -105,13 +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) -> +#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 +#if defined OXCAML + match var with + | None -> typ + | Some var -> +#endif #if OCAML_VERSION >= (5,2,0) - Alias(typ, var.txt) + Alias(typ, var.txt) #else - Alias(typ, var) + Alias(typ, var) #endif + ) | Ttyp_variant(fields, closed, present) -> let open TypeExpr.Polymorphic_variant in let elements = @@ -142,7 +166,13 @@ let rec read_core_type env container ctyp = in Polymorphic_variant {kind; elements} | Ttyp_poly([], typ) -> read_core_type env container typ +#if defined OXCAML + | 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 @@ -164,6 +194,12 @@ let rec read_core_type env container ctyp = (* TODO: adjust model *) read_core_type env container t #endif +#if defined OXCAML + | Ttyp_quote typ -> Quote (read_core_type env container typ) + | Ttyp_splice typ -> Splice (read_core_type env container typ) + | 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 @@ -179,14 +215,21 @@ 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 let desc = 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 = @@ -214,13 +257,29 @@ 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_ = (ld.ld_mutable = 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_} + +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_ = is_mutable ld.ld_mutable in let type_ = read_core_type env label_parent ld.ld_type in {id; doc; mutable_; type_} @@ -231,7 +290,12 @@ 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 -> +#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 @@ -261,6 +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 = @@ -286,7 +358,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 @@ -365,7 +438,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 @@ -400,8 +474,13 @@ 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 +#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 = let open ClassType in @@ -445,7 +524,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 @@ -484,7 +564,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 @@ -597,6 +678,16 @@ 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 + 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" +#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. *) @@ -627,7 +718,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 @@ -666,7 +758,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 @@ -724,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 @@ -780,11 +877,17 @@ 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 }] | _ -> + (* TODO: Handle [include functor] *) content.items and read_open env parent o = 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/dune b/src/loader/dune index f77d0b8fb6..055da90366 100644 --- a/src/loader/dune +++ b/src/loader/dune @@ -1,24 +1,8 @@ -(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) + (enabled_if + (not %{ocaml-config:ox})) (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) @@ -29,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.cppo.ml b/src/loader/ident_env.ml similarity index 96% rename from src/loader/ident_env.cppo.ml rename to src/loader/ident_env.ml index 805728d475..54788364af 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.ml @@ -118,9 +118,16 @@ 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 -> +#elif defined OXCAML + | Type_variant (cstrs, _, _) -> #else | Type_variant (cstrs, _) -> #endif @@ -210,6 +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 @@ -249,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 @@ -302,12 +316,16 @@ let rec read_pattern hide_item pat = match pat.pat_desc with #if OCAML_VERSION < (5,2,0) | 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 defined OXCAML + | Tpat_alias(pat, id, loc, _, _, _, _) -> #elif OCAML_VERSION < (5,4,0) | Tpat_alias(pat, id, loc, _) -> #else @@ -316,12 +334,19 @@ 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 | Tpat_construct(_, _, pats, _) #endif -#if OCAML_VERSION < (5,4,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) | Tpat_array pats -> List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) #else @@ -329,10 +354,14 @@ 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) || 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 defined OXCAML + | Tpat_unboxed_tuple pats -> + List.concat (List.map (fun (_, pat, _) -> read_pattern hide_item pat) pats) #endif | Tpat_or(pat, _, _) | Tpat_variant(_, Some pat, _) @@ -356,6 +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 @@ -677,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.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/ident_env.cppo.mli b/src/loader/ident_env.mli similarity index 98% rename from src/loader/ident_env.cppo.mli rename to src/loader/ident_env.mli index 337f9ffafe..531ceb6261 100644 --- a/src/loader/ident_env.cppo.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 73b4bb73bf..d3924a67b7 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -1,14 +1,23 @@ #if OCAML_VERSION >= (4, 14, 0) let rec is_persistent : Path.t -> bool = function - | Path.Pident id -> Ident.persistent 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) | 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 @@ -70,6 +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 @@ -208,6 +220,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/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index b3810f456b..0ad0d28941 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 @@ -101,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 @@ -112,16 +127,28 @@ 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 |> unit_name_as_string in let sourcefile = ( cmt_info.cmt_sourcefile, 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 - compilation_unit_of_sig ~make_root ~imports:cmt_info.cmt_imports +#if defined OXCAML + 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 +#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 @@ -130,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 in + let name = cmt_info.cmt_modname |> unit_name_as_string in let sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, @@ -147,7 +174,17 @@ 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 -> + Import_info.name import |> Compilation_unit.Name.to_string, + 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 = @@ -177,6 +214,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 @@ -184,14 +223,44 @@ 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 - match cmi_info.cmi_crcs with + 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 |> 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) -> + name |> Compilation_unit.Name.to_string, + 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 @@ -200,7 +269,7 @@ 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 |> unit_name_as_string in let _sourcefile = ( cmt_info.cmt_sourcefile, cmt_info.cmt_source_digest, @@ -208,6 +277,15 @@ let read_impl ~make_root ~filename ~source_id () = in let interface = cmt_info.cmt_interface_digest in let imports = cmt_info.cmt_imports in +#if defined OXCAML + let 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 8bd0375160..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,7 +30,9 @@ 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) -> ( @@ -35,10 +42,12 @@ module Analysis = struct | 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/model/compat.cppo.ml b/src/model/compat.cppo.ml index b5e528955b..05733302cd 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 @@ -93,6 +98,14 @@ and module_type : Types.module_type -> module_type = function | 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 @@ -273,16 +286,23 @@ 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 = 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/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/model/lang.ml b/src/model/lang.ml index 429067ead7..41b7c6ba3f 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 { Lexing.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; @@ -83,6 +93,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,17 +107,26 @@ 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; 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; @@ -213,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 @@ -228,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 @@ -253,6 +283,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; @@ -290,6 +321,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; @@ -305,6 +337,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; @@ -322,6 +355,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; @@ -341,6 +375,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; @@ -440,11 +475,14 @@ 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 | 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 @@ -482,12 +520,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 @@ -504,7 +549,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 = @@ -552,6 +597,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 +607,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/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 da0ebad61e..5c509481e9 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 @@ -309,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 @@ -332,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 = @@ -630,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 -> @@ -638,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} *) @@ -741,6 +771,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 @@ -748,6 +832,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 = 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/odoc/classify.cppo.ml b/src/odoc/classify.cppo.ml index 417bf817ef..367b006fb7 100644 --- a/src/odoc/classify.cppo.ml +++ b/src/odoc/classify.cppo.ml @@ -15,6 +15,18 @@ let debug = ref false let log fmt = if !debug then Format.printf fmt else Format.ifprintf Format.std_formatter fmt +#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 @@ -39,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 { @@ -47,8 +65,8 @@ module Archive = struct StringSet.add (Odoc_model.Compat.compunit_name cu.cu_name) lib.modules; intf_deps = List.fold_left - (fun deps (cu, _) -> StringSet.add cu deps) - lib.intf_deps cu.cu_imports; + (fun deps import -> StringSet.add (name_of_import import) deps) + lib.intf_deps (cu_imports cu); impl_deps = List.fold_left (fun deps id -> StringSet.add id deps) @@ -56,19 +74,25 @@ 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 +#if defined OXCAML + |> Compilation_unit.name_as_string +#endif + 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 +120,9 @@ 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 -> + let cmi_crcs = cmi_crcs cmi in + List.map name_of_import cmi_crcs |> StringSet.of_list | None -> StringSet.empty end @@ -166,7 +192,34 @@ 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)) +#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 *) + 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 +#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 @@ -175,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 d1eb392431..fe72206811 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -35,17 +35,20 @@ end module Compile_set = Set.Make (Compile) -let add_dep acc = function - | _, None -> acc (* drop module aliases *) +let add_dep acc import = + 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 - List.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 - List.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 6d98c2ce63..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/search/html.ml b/src/search/html.ml index cb090f1f44..d1ddf9748d 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 @@ -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 @@ -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 @@ -222,7 +227,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..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) -> @@ -135,7 +139,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 = @@ -211,6 +215,13 @@ let of_entry ({ Entry.id; doc; kind } 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/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 2a4732f831..d8c3b5a18c 100644 --- a/src/syntax_highlighter/syntax_highlighter.ml +++ b/src/syntax_highlighter/syntax_highlighter.ml @@ -145,6 +145,32 @@ let tag_of_token (tok : Parser.token) = | ANDOP _ -> "ANDOP" | LETOP _ -> "LETOP" #endif +#if defined OXCAML + | 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" | METAOCAML_BRACKET_OPEN -> "METAOCAML_BRACKET_OPEN" @@ -152,6 +178,7 @@ let tag_of_token (tok : Parser.token) = | EFFECT -> "EFFECT" #endif + let syntax_highlighting_locs src = try Lexer.init (); diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 0ccc1a7529..3873010d1c 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 -> @@ -775,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 @@ -906,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 @@ -931,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 b2068e8030..6bc682e5ad 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; @@ -123,11 +124,14 @@ 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 | 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 @@ -156,6 +160,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; @@ -199,6 +204,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,15 +218,24 @@ 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; + 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; @@ -238,6 +253,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 @@ -253,6 +277,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 @@ -269,6 +294,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; @@ -282,6 +308,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; @@ -353,6 +380,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; @@ -369,6 +397,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; @@ -510,6 +539,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 ] @@ -529,6 +561,7 @@ module Element = struct | extension | extension_decl | field + | unboxed_field | page ] let identifier : [< any ] -> Odoc_model.Paths.Identifier.t = @@ -544,6 +577,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) @@ -697,6 +731,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) @@ -943,6 +981,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 +1001,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 @@ -996,6 +1039,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 = @@ -1018,8 +1062,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 @@ -1139,6 +1191,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 @@ -1152,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 : @@ -1618,6 +1673,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) @@ -1714,6 +1774,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) @@ -2149,6 +2213,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; @@ -2163,6 +2228,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 = @@ -2193,6 +2260,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 { @@ -2264,6 +2340,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) @@ -2272,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 = @@ -2317,6 +2397,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; @@ -2383,6 +2464,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; @@ -2409,6 +2491,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 +2555,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 = @@ -2476,6 +2572,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; @@ -2488,6 +2585,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 = @@ -2509,6 +2607,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; @@ -2536,6 +2635,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; @@ -2615,6 +2715,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; @@ -2736,6 +2837,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 cb0a60eb07..aab0e19ec6 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; @@ -118,11 +119,14 @@ 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 | Class of Cpath.class_type * t list | Poly of string list * t + | Quote of t + | Splice of t | Package of TypeExpr.Package.t end @@ -149,6 +153,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; @@ -190,6 +195,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,15 +209,24 @@ 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; + 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; @@ -228,6 +243,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 @@ -243,6 +267,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 @@ -259,6 +284,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; @@ -324,6 +350,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; @@ -337,6 +364,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; @@ -352,6 +380,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; @@ -486,6 +515,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 ] @@ -505,6 +537,7 @@ module Element : sig | extension | extension_decl | field + | unboxed_field | page ] val identifier : [< any ] -> Identifier.t 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/env.ml b/src/xref2/env.ml index 0ef9963fe3..0dccefc7a2 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,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; + [@warning "-unused-field"] resolver : resolver option; recorder : recorder option; warnings_tags : string list; @@ -212,6 +216,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 +247,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 +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 + add_label id + { Component.Label.attrs; label; text; location } + env ~unboxed:false | _ -> env) env docs.elements @@ -295,7 +304,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 +329,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 +345,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 @@ -381,6 +400,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 +415,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 @@ -625,6 +646,11 @@ 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 @@ -656,6 +682,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 +857,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/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..7d28e5b488 100644 --- a/src/xref2/expand_tools.ml +++ b/src/xref2/expand_tools.ml @@ -58,12 +58,15 @@ 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) | 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/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 2401576c00..7cbfcf3ba7 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; @@ -799,6 +803,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 +857,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 -> @@ -864,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; @@ -912,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 = @@ -932,6 +963,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; @@ -951,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 -> @@ -992,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), @@ -1002,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 @@ -1061,6 +1103,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/link.ml b/src/xref2/link.ml index 4e8c5e099c..a52c8c361f 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 = @@ -893,6 +903,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 +970,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 -> @@ -968,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 = @@ -1030,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 @@ -1109,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 @@ -1172,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/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..e32fa997cc 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,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 @@ -155,6 +158,14 @@ let lookup_shape : Env.t -> Shape.t -> Identifier.SourceLocation.t option = | Some (shape, _) -> Some shape | None -> None) | _ -> None +#if defined OXCAML + 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 -> diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 56658e4e3b..daee32e456 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -125,12 +125,16 @@ 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) | 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 = @@ -489,6 +493,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 +554,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) -> @@ -563,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 : @@ -580,7 +589,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 @@ -613,13 +622,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 +661,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 @@ -685,6 +707,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/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/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
"} 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 = 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 diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index c716cb42f8..e6d128c491 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -18,6 +18,11 @@ 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 (); let env = Compmisc.initial_env () in @@ -26,6 +31,9 @@ let cmti_of_string s = Typemod.type_interface #if OCAML_VERSION >= (4,4,0) && OCAML_VERSION < (4,9,0) "" +#elif defined OXCAML + ~sourcefile:"" + dummy_compilation_unit #endif env p;; @@ -33,7 +41,9 @@ 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 @@ -603,6 +613,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 () = 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)