From 4cf7ff88e1b801b60c01509cc309dce972ec7e65 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 12 Jul 2023 17:33:41 +0200 Subject: [PATCH] Search : printing update --- src/search/entry.ml | 92 ++++------- src/search/entry.mli | 8 +- src/search/generator.ml | 311 ++++++++++++++++++++++++------------ src/search/generator.mli | 51 +++++- src/search/json_display.ml | 79 +-------- src/search/json_display.mli | 12 +- src/search/json_search.ml | 11 +- 7 files changed, 307 insertions(+), 257 deletions(-) diff --git a/src/search/entry.ml b/src/search/entry.ml index dde9f93f10..bd11ffd01d 100644 --- a/src/search/entry.ml +++ b/src/search/entry.ml @@ -41,7 +41,7 @@ type doc_entry = Paragraph | Heading | CodeBlock | MathBlock | Verbatim type value_entry = { value : Value.value; type_ : TypeExpr.t } -type extra = +type kind = | TypeDecl of type_decl_entry | Module | Value of value_entry @@ -61,13 +61,14 @@ module Html = Tyxml.Html type t = { id : Odoc_model.Paths.Identifier.Any.t; doc : Odoc_model.Comment.docs; - extra : extra; - html : Html_types.div Html.elt; + kind : kind; } -let entry ~id ~doc ~extra ~html = +type with_html = { entry : t; html : [ `Code | `Div ] Tyxml.Html.elt list } + +let entry ~id ~doc ~kind = let id = (id :> Odoc_model.Paths.Identifier.Any.t) in - { id; extra; doc; html } + { id; kind; doc } let varify_params = List.mapi (fun i param -> @@ -77,15 +78,6 @@ let varify_params = let entry_of_constructor id_parent params (constructor : TypeDecl.Constructor.t) = - let html = - Tyxml.Html.div ~a:[] - [ - Tyxml.Html.txt - @@ Generator.constructor - (constructor.id :> Identifier.t) - constructor.args constructor.res; - ] - in let args = constructor.args in let res = match constructor.res with @@ -97,20 +89,11 @@ let entry_of_constructor id_parent params (constructor : TypeDecl.Constructor.t) ((id_parent :> Odoc_model.Paths.Identifier.Path.Type.t), false), params ) in - let extra = Constructor { args; res } in - entry ~id:constructor.id ~doc:constructor.doc ~extra ~html + let kind = Constructor { args; res } in + entry ~id:constructor.id ~doc:constructor.doc ~kind let entry_of_extension_constructor id_parent params (constructor : Extension.Constructor.t) = - let html = - Tyxml.Html.div ~a:[] - [ - Tyxml.Html.txt - @@ Generator.constructor - (constructor.id :> Identifier.t) - constructor.args constructor.res; - ] - in let args = constructor.args in let res = match constructor.res with @@ -119,8 +102,8 @@ let entry_of_extension_constructor id_parent params let params = varify_params params in TypeExpr.Constr (id_parent, params) in - let extra = ExtensionConstructor { args; res } in - entry ~id:constructor.id ~doc:constructor.doc ~extra ~html + let kind = ExtensionConstructor { args; res } in + entry ~id:constructor.id ~doc:constructor.doc ~kind let entry_of_field id_parent params (field : TypeDecl.Field.t) = let params = varify_params params in @@ -130,25 +113,21 @@ let entry_of_field id_parent params (field : TypeDecl.Field.t) = ((id_parent :> Odoc_model.Paths.Identifier.Path.Type.t), false), params ) in - let extra = + let kind = Field { mutable_ = field.mutable_; type_ = field.type_; parent_type } in - let html = Html.div ~a:[] [] in - entry ~id:field.id ~doc:field.doc ~extra ~html + entry ~id:field.id ~doc:field.doc ~kind let rec entries_of_docs (d : Odoc_model.Comment.docs) = List.concat_map entries_of_doc d and entries_of_doc d = - let html = Html.div ~a:[] [] in match d.value with - | `Paragraph (lbl, _) -> - [ entry ~id:lbl ~doc:[ d ] ~extra:(Doc Paragraph) ~html ] + | `Paragraph (lbl, _) -> [ entry ~id:lbl ~doc:[ d ] ~kind:(Doc Paragraph) ] | `Tag _ -> [] | `List (_, ds) -> List.concat_map entries_of_docs (ds :> Odoc_model.Comment.docs list) - | `Heading (_, lbl, _) -> - [ entry ~id:lbl ~doc:[ d ] ~extra:(Doc Heading) ~html ] + | `Heading (_, lbl, _) -> [ entry ~id:lbl ~doc:[ d ] ~kind:(Doc Heading) ] | `Modules _ -> [] | `Code_block (lbl, _, _, o) -> let o = @@ -156,23 +135,20 @@ and entries_of_doc d = | None -> [] | Some o -> entries_of_docs (o :> Odoc_model.Comment.docs) in - entry ~id:lbl ~doc:[ d ] ~extra:(Doc CodeBlock) ~html :: o - | `Verbatim (lbl, _) -> - [ entry ~id:lbl ~doc:[ d ] ~extra:(Doc Verbatim) ~html ] - | `Math_block (lbl, _) -> - [ entry ~id:lbl ~doc:[ d ] ~extra:(Doc MathBlock) ~html ] + entry ~id:lbl ~doc:[ d ] ~kind:(Doc CodeBlock) :: o + | `Verbatim (lbl, _) -> [ entry ~id:lbl ~doc:[ d ] ~kind:(Doc Verbatim) ] + | `Math_block (lbl, _) -> [ entry ~id:lbl ~doc:[ d ] ~kind:(Doc MathBlock) ] | `Table _ -> [] let entries_of_item (x : Odoc_model.Fold.item) = - let html = Generator.html_of_entry x in match x with | CompilationUnit u -> ( match u.content with - | Module m -> [ entry ~id:u.id ~doc:m.doc ~extra:Module ~html ] + | Module m -> [ entry ~id:u.id ~doc:m.doc ~kind:Module ] | Pack _ -> []) | TypeDecl td -> let txt = Render.text_of_typedecl td in - let extra = + let kind = TypeDecl { txt; @@ -181,7 +157,7 @@ let entries_of_item (x : Odoc_model.Fold.item) = representation = td.representation; } in - let td_entry = entry ~id:td.id ~doc:td.doc ~extra ~html in + let td_entry = entry ~id:td.id ~doc:td.doc ~kind in let subtype_entries = match td.representation with | None -> [] @@ -192,28 +168,28 @@ let entries_of_item (x : Odoc_model.Fold.item) = | Some Extensible -> [] in td_entry :: subtype_entries - | Module m -> [ entry ~id:m.id ~doc:m.doc ~extra:Module ~html ] + | Module m -> [ entry ~id:m.id ~doc:m.doc ~kind:Module ] | Value v -> - let extra = Value { value = v.value; type_ = v.type_ } in - [ entry ~id:v.id ~doc:v.doc ~extra ~html ] + let kind = Value { value = v.value; type_ = v.type_ } in + [ entry ~id:v.id ~doc:v.doc ~kind ] | Exception exc -> let res = Option.value exc.res ~default:(TypeExpr.Constr (Odoc_model.Predefined.exn_path, [])) in - let extra = Exception { args = exc.args; res } in - [ entry ~id:exc.id ~doc:exc.doc ~extra ~html ] + let kind = Exception { args = exc.args; res } in + [ entry ~id:exc.id ~doc:exc.doc ~kind ] | ClassType ct -> - let extra = Class_type { virtual_ = ct.virtual_; params = ct.params } in - [ entry ~id:ct.id ~doc:ct.doc ~extra ~html ] + let kind = Class_type { virtual_ = ct.virtual_; params = ct.params } in + [ entry ~id:ct.id ~doc:ct.doc ~kind ] | Method m -> - let extra = + let kind = Method { virtual_ = m.virtual_; private_ = m.private_; type_ = m.type_ } in - [ entry ~id:m.id ~doc:m.doc ~extra ~html ] + [ entry ~id:m.id ~doc:m.doc ~kind ] | Class cl -> - let extra = Class { virtual_ = cl.virtual_; params = cl.params } in - [ entry ~id:cl.id ~doc:cl.doc ~extra ~html ] + let kind = Class { virtual_ = cl.virtual_; params = cl.params } in + [ entry ~id:cl.id ~doc:cl.doc ~kind ] | Extension te -> ( match te.constructors with | [] -> [] @@ -222,7 +198,7 @@ let entries_of_item (x : Odoc_model.Fold.item) = constructor for the url. Unfortunately, this breaks the uniqueness of the ID in the search index... *) let type_entry = - let extra = + let kind = TypeExtension { type_path = te.type_path; @@ -230,13 +206,13 @@ let entries_of_item (x : Odoc_model.Fold.item) = private_ = te.private_; } in - entry ~id:c.id ~doc:te.doc ~extra ~html + entry ~id:c.id ~doc:te.doc ~kind in type_entry :: List.map (entry_of_extension_constructor te.type_path te.type_params) te.constructors) - | ModuleType mt -> [ entry ~id:mt.id ~doc:mt.doc ~extra:ModuleType ~html ] + | ModuleType mt -> [ entry ~id:mt.id ~doc:mt.doc ~kind:ModuleType ] | Doc `Stop -> [] | Doc (`Docs d) -> entries_of_docs d diff --git a/src/search/entry.mli b/src/search/entry.mli index 173c91c684..ac64d8c65d 100644 --- a/src/search/entry.mli +++ b/src/search/entry.mli @@ -41,7 +41,7 @@ type doc_entry = Paragraph | Heading | CodeBlock | MathBlock | Verbatim type value_entry = { value : Value.value; type_ : TypeExpr.t } -type extra = +type kind = | TypeDecl of type_decl_entry | Module | Value of value_entry @@ -59,8 +59,10 @@ type extra = type t = { id : Odoc_model.Paths.Identifier.Any.t; doc : Odoc_model.Comment.docs; - extra : extra; - html : Html_types.div Tyxml.Html.elt; + kind : kind; } +type with_html = { entry : t; html : [ `Code | `Div ] Tyxml.Html.elt list } +(** You can use {!Generator.with_html} to get a value of this type. *) + val entries_of_item : Odoc_model.Fold.item -> t list diff --git a/src/search/generator.ml b/src/search/generator.ml index e54db430db..a296d290b2 100644 --- a/src/search/generator.ml +++ b/src/search/generator.ml @@ -1,49 +1,50 @@ module Html = Tyxml.Html open Odoc_model - -let constructor id _args _res = - let name = Paths.Identifier.name id in - Format.sprintf "constructor %s : " name +open Lang +open Printf let type_from_path : Paths.Path.Type.t -> string = fun path -> match path with | `Identifier (id, _) -> Paths.Identifier.name id - | `Dot (_prefix, suffix) -> Format.sprintf "%s" suffix + | `Dot (_prefix, suffix) -> sprintf "%s" suffix | `Resolved _ when Paths.Path.is_hidden (path :> Paths.Path.t) -> "TODO" | `Resolved rp -> let id = Paths.Path.Resolved.identifier (rp :> Paths.Path.Resolved.t) in let name = Paths.Identifier.name id in - Format.sprintf "%s" name + sprintf "%s" name -let rec format_type_path ~delim (params : Odoc_model.Lang.TypeExpr.t list) path - = +let rec format_type_path ~delim (params : TypeExpr.t list) path = let enclose = - match delim with - | `brackets -> Format.sprintf "(%s)" - | _ -> Format.sprintf "[%s]" + match delim with `brackets -> sprintf "(%s)" | _ -> sprintf "[%s]" in match params with | [] -> path | [ param ] -> let args = type_expr ~needs_parentheses:true param in - Format.sprintf "%s %s" args path + sprintf "%s %s" args path | params -> let params = List.map type_expr params in - let args = Format.sprintf "(%s)" (String.concat ", " params) in - enclose @@ Format.sprintf "%s %s" args path + let args = sprintf "(%s)" (String.concat ", " params) in + enclose @@ sprintf "%s %s" args path -and type_expr ?(needs_parentheses = false) (t : Odoc_model.Lang.TypeExpr.t) = +and type_expr ?(needs_parentheses = false) (t : TypeExpr.t) = match t with - | Var s -> Format.sprintf "'%s" s + | Var s -> sprintf "'%s" s | Any -> "_" | Alias (te, alias) -> - Printf.sprintf "%s as %s" (type_expr ~needs_parentheses:true te) alias + let res = + Printf.sprintf "%s as %s" (type_expr ~needs_parentheses:true te) alias + in + if needs_parentheses then "(" ^ res ^ ")" else res | Arrow (None, src, dst) -> - Printf.sprintf "%s -> %s" - (type_expr ~needs_parentheses:true src) - (type_expr dst) + let res = + Printf.sprintf "%s -> %s" + (type_expr ~needs_parentheses:true src) + (type_expr dst) + in + if needs_parentheses then "(" ^ res ^ ")" else res | Arrow (Some (Label lbl), src, dst) -> let res = Printf.sprintf "%s:%s -> %s" lbl @@ -64,102 +65,193 @@ and type_expr ?(needs_parentheses = false) (t : Odoc_model.Lang.TypeExpr.t) = if not needs_parentheses then res else "(" ^ res ^ ")" | Constr (args, link) -> format_type_path ~delim:`parens link (type_from_path args) - | Polymorphic_variant _ -> "TODO" - | Object _ -> "TODO" - | Class (_, _) -> "TODO" - | Poly (_, _) -> "TODO" - | Package _ -> "TODO" - -let format_params : - ?delim:[ `parens | `brackets ] -> - Odoc_model.Lang.TypeDecl.param list -> - string = - fun ?(delim = `parens) params -> - let format_param { Odoc_model.Lang.TypeDecl.desc; variance; injectivity } = + | Polymorphic_variant _ -> "{TODO Polymorphic variant}" + | Object _ -> "{TODO Object}" + | Class (_, _) -> "{TODO Class}" + | Poly (_, _) -> "{TODO Poly}" + | Package _ -> "{TODO Package}" + +let display_constructor_args args = + let open Odoc_model.Lang in + match args with + | TypeDecl.Constructor.Tuple args -> + (match args with + | _ :: _ :: _ -> Some TypeExpr.(Tuple args) + | [ arg ] -> Some arg + | _ -> None) + |> Option.map type_expr + | TypeDecl.Constructor.Record fields -> Some (Render.text_of_record fields) + +let constructor_rhs ~args ~res = + let args = display_constructor_args args in + let res = Option.map type_expr res in + match (args, res) with + | None, None -> "" + | None, Some res -> " : " ^ res + | Some args, None -> " of " ^ args + | Some args, Some res -> " : " ^ args ^ " -> " ^ res + +let field_rhs Entry.{ mutable_ = _; type_; parent_type = _ } = + " : " ^ type_expr type_ + +let typedecl_params ?(delim = `parens) params = + let format_param { TypeDecl.desc; variance; injectivity } = let desc = - match desc with - | Odoc_model.Lang.TypeDecl.Any -> [ "_" ] - | Var s -> [ "'"; s ] + match desc with TypeDecl.Any -> [ "_" ] | Var s -> [ "'"; s ] in let var_desc = match variance with | None -> desc - | Some Odoc_model.Lang.TypeDecl.Pos -> "+" :: desc - | Some Odoc_model.Lang.TypeDecl.Neg -> "-" :: desc + | Some TypeDecl.Pos -> "+" :: desc + | Some TypeDecl.Neg -> "-" :: desc in let final = if injectivity then "!" :: var_desc else var_desc in String.concat "" final in match params with - | [] -> "" - | [ x ] -> format_param x - | lst -> ( + | [] -> None + | [ x ] -> Some (format_param x) + | lst -> let params = String.concat ", " (List.map format_param lst) in - (match delim with `parens -> "(" | `brackets -> "[") - ^ params - ^ match delim with `parens -> ")" | `brackets -> "]") - -let html_of_entry (entry : Odoc_model.Fold.item) = - let content = - match entry with - | CompilationUnit { content = Module _; id; _ } -> - let name = Paths.Identifier.name id in - Printf.sprintf "module %s = struct ... end" name - | CompilationUnit { content = Pack _; _ } -> "" - | TypeDecl t -> - let tyname = Paths.Identifier.name t.id in - let repr = - match t.representation with - | None -> "" - | Some repr -> ( - match repr with - | Extensible -> " = .." - | Variant _ -> " = " - | Record _ -> " = ") - in - Format.sprintf "type %s%s" tyname repr - | Module t -> - let modname = Paths.Identifier.name t.id in - Format.sprintf "module %s : sig ... end" modname - | Value t -> - let external_ = - match t.value with Abstract -> "" | External _ -> "external " - in - let name = Paths.Identifier.name t.id in - Format.sprintf "%sval %s : %s" external_ name (type_expr t.type_) - | Exception t -> - let cstr = constructor (t.id :> Paths.Identifier.t) t.args t.res in - Format.sprintf "exception %s" cstr - | ClassType t -> - let name = Paths.Identifier.name t.id in - let params = format_params ~delim:`brackets t.params in - let virtual_ = if t.virtual_ then "virtual " else "" in - Format.sprintf "class type %s%s%s = object ... end" virtual_ params name - | Method t -> - let name = Paths.Identifier.name t.id in - let virtual_ = if t.virtual_ then "virtual " else "" in - let private_ = if t.private_ then "private " else "" in - Format.sprintf "val %s%s%s : %s" private_ virtual_ name - (type_expr t.type_) - | Class t -> - let name = Paths.Identifier.name t.id in - let params = - match t.params with - | [] -> "" - | _ :: _ as params -> format_params ~delim:`brackets params ^ " " - in - let virtual_ = if t.virtual_ then "virtual" else "" in - Format.sprintf "class %s%s%s = object ... end" virtual_ params name - | Extension t -> - let name = type_from_path t.type_path in - Format.sprintf "type %s += ..." name - | ModuleType t -> - let modname = Paths.Identifier.name t.id in - Format.sprintf "module type %s = sig ... end" modname - | Doc _ -> "" + Some + ((match delim with `parens -> "(" | `brackets -> "[") + ^ params + ^ match delim with `parens -> ")" | `brackets -> "]") + +let type_decl_constraint (typ, typ') = + "constraint" ^ " " ^ type_expr typ ^ " = " ^ type_expr typ' + +let typedecl_params_of_entry Entry.{ kind; _ } = + match kind with + | Entry.TypeDecl { txt = _; canonical = _; equation; representation = _ } -> + typedecl_params equation.params + | _ -> None + +let typedecl_repr ~private_ (repr : TypeDecl.Representation.t) = + let constructor ~id ~args ~res = + let name = Comment.Identifier.name id in + name ^ constructor_rhs ~args ~res + in + let private_ = if private_ then "private " else "" in + "= " ^ private_ + ^ + match repr with + | Extensible -> ".." + | Variant constructors -> + constructors + |> List.map (fun TypeDecl.Constructor.{ id; args; res; _ } -> + constructor ~id ~args ~res) + |> String.concat " | " + | Record record -> Render.text_of_record record + +let typedecl_rhs Entry.{ equation; representation; _ } = + let TypeDecl.Equation.{ private_; manifest; constraints; _ } = equation in + let repr = + representation + |> Option.map (typedecl_repr ~private_) + |> Option.value ~default:"" + in + let manifest = + match manifest with None -> "" | Some typ -> " = " ^ type_expr typ + in + let constraints = + match constraints with + | [] -> "" + | _ :: _ -> + " " ^ (constraints |> List.map type_decl_constraint |> String.concat " ") + in + match repr ^ manifest ^ constraints with "" -> None | r -> Some r + +let constructor_rhs Entry.{ args; res } = constructor_rhs ~args ~res:(Some res) + +(** Kinds *) + +let kind_doc = "doc" + +let kind_typedecl = "type" + +let kind_module = "mod" + +let kind_exception = "exn" + +let kind_class_type = "class" +let kind_class = "class" + +let kind_method = "meth" + +let kind_extension_constructor = "cons" + +let kind_module_type = "sig" + +let kind_constructor = "cons" + +let kind_field = "field" + +let kind_value = "val" + +let kind_extension = "ext" + +let string_of_kind = + let open Entry in + function + | Constructor _ -> kind_constructor + | Field _ -> kind_field + | ExtensionConstructor _ -> kind_extension_constructor + | TypeDecl _ -> kind_typedecl + | Module -> kind_module + | Value _ -> kind_value + | Exception _ -> kind_exception + | Class_type _ -> kind_class_type + | Method _ -> kind_method + | Class _ -> kind_class + | TypeExtension _ -> kind_extension + | ModuleType -> kind_module_type + | Doc _ -> kind_class_type + +let value_rhs (t : Entry.value_entry) = " : " ^ type_expr t.type_ + +let html_of_strings ~kind ~prefix_name ~name ~rhs ~typedecl_params ~doc = + let open Tyxml.Html in + let kind = code ~a:[ a_class [ "entry-kind" ] ] [ txt kind ] + and prefix_name = + span + ~a:[ a_class [ "prefix-name" ] ] + [ + txt + ((match typedecl_params with None -> "" | Some p -> p ^ " ") + ^ prefix_name ^ "."); + ] + and name = span ~a:[ a_class [ "entry-name" ] ] [ txt name ] + and rhs = + match rhs with + | None -> [] + | Some rhs -> [ code ~a:[ a_class [ "entry_rhs" ] ] [ txt rhs ] ] in - Html.div ~a:[] [ Html.txt content ] + [ + kind; + code ~a:[ a_class [ "entry-title" ] ] ([ prefix_name; name ] @ rhs); + div ~a:[ a_class [ "entry-comment" ] ] [ Unsafe.data doc ]; + ] + +let rhs_of_kind (entry : Entry.kind) = + match entry with + | TypeDecl td -> typedecl_rhs td + | Value t -> Some (value_rhs t) + | Constructor t | ExtensionConstructor t | Exception t -> + Some (constructor_rhs t) + | Field f -> Some (field_rhs f) + | Module | Class_type _ | Method _ | Class _ | TypeExtension _ | ModuleType + | Doc _ -> + None +let title_of_id id = + let fullname = Paths.Identifier.fullname id in + let prefix_name, name = + let rev_fullname = List.rev fullname in + ( rev_fullname |> List.tl |> List.rev |> String.concat ".", + List.hd rev_fullname ) + in + (prefix_name, name) let html_of_doc doc = let config = Odoc_html.Config.v ~search_result:true ~semantic_uris:false ~indent:false @@ -168,3 +260,16 @@ let html_of_doc doc = Tyxml.Html.div ~a:[] @@ Odoc_html.Generator.doc ~config ~xref_base_uri:"" @@ Odoc_document.Comment.to_ir doc + +let html_string_of_doc doc = + doc |> html_of_doc |> Format.asprintf "%a" (Html.pp_elt ()) +let html_of_entry (entry : Entry.t) = + let Entry.{ id; doc; kind } = entry in + let rhs = rhs_of_kind kind in + let prefix_name, name = title_of_id id in + let doc = html_string_of_doc doc in + let kind = string_of_kind kind in + let typedecl_params = typedecl_params_of_entry entry in + html_of_strings ~kind ~prefix_name ~name ~rhs ~doc ~typedecl_params + +let with_html entry = Entry.{ entry; html = html_of_entry entry } diff --git a/src/search/generator.mli b/src/search/generator.mli index eee13468ef..89f64de094 100644 --- a/src/search/generator.mli +++ b/src/search/generator.mli @@ -1,6 +1,51 @@ open Odoc_model -val constructor : Paths.Identifier.t -> 'b -> 'c -> string +module Html = Tyxml_html + +val title_of_id : Paths.Identifier.t -> string * string +val html_of_doc : Comment.docs -> [> Html_types.div ] Tyxml_html.elt +val html_string_of_doc : Comment.docs -> string + +val html_of_entry : Entry.t -> [> `Code | `Div ] Tyxml_html.elt list + +val with_html : Entry.t -> Entry.with_html + +(** Right-hand sides *) + val type_expr : ?needs_parentheses:bool -> Lang.TypeExpr.t -> string -val html_of_entry : Fold.item -> Html_types.div Tyxml.Html.elt -val html_of_doc : Comment.docs -> Html_types.div Tyxml.Html.elt + +val constructor_rhs : Entry.constructor_entry -> string +val field_rhs : Entry.field_entry -> string + +val typedecl_rhs : Entry.type_decl_entry -> string option + +val value_rhs : Entry.value_entry -> string +val html_of_strings : + kind:string -> + prefix_name:string -> + name:string -> + rhs:string option -> + typedecl_params:string option -> + doc:string -> + [> `Code | `Div ] Tyxml_html.elt list + +val rhs_of_kind : Entry.kind -> string option + +(** Kinds *) + +val string_of_kind : Entry.kind -> string +(** Does not include the rhs. *) + +val kind_doc : string +val kind_typedecl : string +val kind_module : string +val kind_exception : string +val kind_class_type : string +val kind_class : string +val kind_method : string +val kind_extension_constructor : string +val kind_module_type : string +val kind_constructor : string +val kind_field : string +val kind_value : string +val kind_extension : string diff --git a/src/search/json_display.ml b/src/search/json_display.ml index 1fe991008a..8a2f2b1bb9 100644 --- a/src/search/json_display.ml +++ b/src/search/json_display.ml @@ -1,80 +1,9 @@ module Html = Tyxml.Html -let json_of_namelist li = `Array (List.map (fun str -> `String str) li) - -let display_constructor_type args res = - let open Odoc_model.Lang in - match args with - | TypeDecl.Constructor.Tuple args -> - let type_ = - match args with - | _ :: _ :: _ -> TypeExpr.(Arrow (None, Tuple args, res)) - | [ arg ] -> TypeExpr.(Arrow (None, arg, res)) - | _ -> res - in - Render.text_of_type type_ - | TypeDecl.Constructor.Record fields -> - let fields = Render.text_of_record fields in - let res = Render.text_of_type res in - fields ^ " -> " ^ res - -let typedecl_rhs td = - let segments = String.split_on_char '=' td.Entry.txt in - if List.length segments > 1 then - segments |> List.tl |> String.concat "=" |> String.trim |> ( ^ ) " = " - |> Option.some - else None - -let constructor_rhs Entry.{ args; res } = - " : " ^ display_constructor_type args res - -let field_rhs Entry.{ mutable_ = _; type_; parent_type = _ } = - " : " ^ Render.text_of_type type_ - -let rhs_of_kind extra = - let open Entry in - match extra with - | TypeDecl td -> typedecl_rhs td - | Constructor cons | ExtensionConstructor cons | Exception cons -> - Some (constructor_rhs cons) - | Field field -> Some (field_rhs field) - | Value { value = _; type_ } -> Some (" : " ^ Render.text_of_type type_) - | Module | Doc _ | Class_type _ | Method _ | Class _ | TypeExtension _ - | ModuleType -> - None - -let of_strings ~id ~url ~doc ~kind ~rhs : Odoc_html.Json.json = - let rhs = - match rhs with None -> [] | Some rhs -> [ ("rhs", `String rhs) ] - in - let j_url = `String url in - let j_id = json_of_namelist id in - let doc = `String doc in - let kind = `String kind in - `Object (rhs @ [ ("id", j_id); ("url", j_url); ("kind", kind); ("doc", doc) ]) - -let of_entry ({ id; doc; extra; html } : Entry.t) : Odoc_html.Json.json = +let of_entry ({ entry = { id; doc = _; kind = _ }; html } : Entry.with_html) : + Odoc_html.Json.json = let url = Render.url id in - let doc = doc |> Render.html_of_doc in - let kind = - match extra with - | TypeDecl _ -> "type" - | Module -> "module" - | Value _ -> "value" - | Exception _ -> "exception" - | Class_type _ -> "class type" - | Method _ -> "method" - | Class _ -> "class" - | ExtensionConstructor _ -> "extension" - | ModuleType -> "module type" - | Doc _ -> "doc" - | TypeExtension _ -> "type" - | Constructor _ -> "constructor" - | Field _ -> "field" - in - let kind = Html.div ~a:[ Html.a_class [ "entry-kind" ] ] [ Html.txt kind ] in - let html = - Html.div ~a:[ Html.a_class [ "search-entry" ] ] [ kind; html; doc ] - in + + let html = Html.div ~a:[ Html.a_class [ "search-entry" ] ] html in let html = Format.asprintf "%a" (Tyxml.Html.pp_elt ()) html in `Object [ ("url", `String url); ("html", `String html) ] diff --git a/src/search/json_display.mli b/src/search/json_display.mli index a7d9cd612c..e0e0df74c7 100644 --- a/src/search/json_display.mli +++ b/src/search/json_display.mli @@ -1,11 +1 @@ -val of_entry : Entry.t -> Odoc_html.Json.json - -val of_strings : - id:string list -> - url:string -> - doc:string -> - kind:string -> - rhs:string option -> - Odoc_html.Json.json - -val rhs_of_kind : Entry.extra -> string option +val of_entry : Entry.with_html -> Odoc_html.Json.json diff --git a/src/search/json_search.ml b/src/search/json_search.ml index 166659f5be..05b34c60db 100644 --- a/src/search/json_search.ml +++ b/src/search/json_search.ml @@ -84,14 +84,15 @@ let of_doc (doc : Odoc_model.Comment.docs) = let txt = Render.text_of_doc doc in `String txt -let of_entry ({ id; doc; extra; html = _ } as entry : Entry.t) : +let of_entry + ({ entry = { id; doc; kind }; html = _ } as entry : Entry.with_html) : Odoc_html.Json.json = let j_id = of_id id in let doc = of_doc doc in let display = Json_display.of_entry entry in - let extra = + let kind = let return kind arr = `Object (("kind", `String kind) :: arr) in - match extra with + match kind with | TypeDecl { canonical = _; equation; representation = _; txt = _ } -> let { Odoc_model.Lang.TypeDecl.Equation.params = _; @@ -167,7 +168,7 @@ let of_entry ({ id; doc; extra; html = _ } as entry : Entry.t) : ("parent_type", `String (Render.text_of_type parent_type)); ] in - `Object [ ("id", j_id); ("doc", doc); ("extra", extra); ("display", display) ] + `Object [ ("id", j_id); ("doc", doc); ("kind", kind); ("display", display) ] let output_json ppf first entries = let output_json json = @@ -185,6 +186,7 @@ let output_json ppf first entries = let unit ppf u = let f first i = let entries = Entry.entries_of_item i in + let entries = List.map Generator.with_html entries in output_json ppf first entries in let _first = Odoc_model.Fold.unit ~f true u in @@ -193,6 +195,7 @@ let unit ppf u = let page ppf (page : Odoc_model.Lang.Page.t) = let f first i = let entries = Entry.entries_of_item i in + let entries = List.map Generator.with_html entries in output_json ppf first entries in let _first = Odoc_model.Fold.page ~f true page in