Add new json for displaying search results

Updates JS code accordingly.

Co-authored-by: Paul-Elliot <peada@free.fr>

src/html_support_files/odoc_search.js

@@ -17,25 +17,12 @@ document.querySelector(".search-bar").addEventListener("input", (ev) => {
   worker.postMessage(ev.target.value);
 });
 
-function typeSeparator(kind) {
-  switch (kind) {
-    case "Value":
-    case "Constructor":
-    case "Field":
-      return " : ";
-    case "TypeDecl":
-      return " = ";
-    default:
-      return "";
-  }
-}
 
 worker.onmessage = (e) => {
   let results = e.data;
   let search_result = document.querySelector(".search-result");
   search_result.innerHTML = "";
   let f = (entry) => {
-    entry.kind = entry.id[entry.id.length - 1].kind;
     let container = document.createElement("a");
     container.href = base_url + entry.url;
     container.classList.add("search-entry", entry.kind.replace(" ", "-"));
@@ -49,25 +36,23 @@ worker.onmessage = (e) => {
     prefixname.innerText =
       entry.id
         .slice(0, entry.id.length - 1)
-        .map((x) => x.name)
         .join(".") + (entry.id.length > 1 && entry.name != "" ? "." : "");
 
     title.appendChild(kind);
     title.appendChild(prefixname);
 
     let name = document.createElement("span");
     name.classList.add("entry-name");
-    name.innerText = entry.id[entry.id.length - 1].name;
+    name.innerText = entry.id[entry.id.length - 1];
     title.appendChild(name);
-    if (typeof entry.extra.type !== typeof undefined) {
-      let type = document.createElement("code");
-      let sep = typeSeparator(entry.extra.kind);
-      type.classList.add("entry-type");
-      type.innerHTML = sep + entry.extra.type
-      title.appendChild(type);
+    if (typeof entry.rhs !== typeof undefined) {
+      let rhs = document.createElement("code");
+      rhs.classList.add("entry-rhs");
+      rhs.innerHTML = entry.rhs
+      title.appendChild(rhs);
     }
     let comment = document.createElement("div");
-    comment.innerHTML = entry.doc.html;
+    comment.innerHTML = entry.doc;
     comment.classList.add("entry-comment");
 
     container.appendChild(title);

src/model/paths.ml

@@ -75,6 +75,48 @@ module Identifier = struct
     | `Label (parent, _) -> is_internal (parent :> t)
 
   let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t)
+
+  let rec full_name_aux : t -> string list =
+   fun x ->
+    match x.iv with
+    | `Root (_, name) -> [ ModuleName.to_string name ]
+    | `Page (_, name) -> [ PageName.to_string name ]
+    | `LeafPage (_, name) -> [ PageName.to_string name ]
+    | `Module (parent, name) ->
+        ModuleName.to_string name :: full_name_aux (parent :> t)
+    | `Parameter (parent, name) ->
+        ModuleName.to_string name :: full_name_aux (parent :> t)
+    | `Result x -> full_name_aux (x :> t)
+    | `ModuleType (parent, name) ->
+        ModuleTypeName.to_string name :: full_name_aux (parent :> t)
+    | `Type (parent, name) ->
+        TypeName.to_string name :: full_name_aux (parent :> t)
+    | `CoreType name -> [ TypeName.to_string name ]
+    | `Constructor (parent, name) ->
+        ConstructorName.to_string name :: full_name_aux (parent :> t)
+    | `Field (parent, name) ->
+        FieldName.to_string name :: full_name_aux (parent :> t)
+    | `Extension (parent, name) ->
+        ExtensionName.to_string name :: full_name_aux (parent :> t)
+    | `Exception (parent, name) ->
+        ExceptionName.to_string name :: full_name_aux (parent :> t)
+    | `CoreException name -> [ ExceptionName.to_string name ]
+    | `Value (parent, name) ->
+        ValueName.to_string name :: full_name_aux (parent :> t)
+    | `Class (parent, name) ->
+        ClassName.to_string name :: full_name_aux (parent :> t)
+    | `ClassType (parent, name) ->
+        ClassTypeName.to_string name :: full_name_aux (parent :> t)
+    | `Method (parent, name) ->
+        MethodName.to_string name :: full_name_aux (parent :> t)
+    | `InstanceVariable (parent, name) ->
+        InstanceVariableName.to_string name :: full_name_aux (parent :> t)
+    | `Label (parent, name) ->
+        LabelName.to_string name :: full_name_aux (parent :> t)
+
+  let fullname : [< t_pv ] id -> string list =
+   fun n -> List.rev @@ full_name_aux (n :> t)
+
   let is_internal : [< t_pv ] id -> bool = fun n -> is_internal (n :> t)
 
   let rec root id =

src/model/paths.mli

@@ -413,6 +413,9 @@ module Identifier : sig
   val hash : t -> int
 
   val name : [< t_pv ] id -> string
+
+  val fullname : [< t_pv ] id -> string list
+
   val is_internal : [< t_pv ] id -> bool
 
   val root : [< t_pv ] id -> RootModule.t_pv id option

src/odoc/indexing.ml

@@ -36,7 +36,7 @@ let compile ~resolver:_ ~parent:_ ~output ~warnings_options:_ dirs =
     false
   in
   Format.fprintf output "[";
-  fold_dirs ~dirs ~unit:(print Json_output.unit) ~page:(print Json_output.page)
+  fold_dirs ~dirs ~unit:(print Json_search.unit) ~page:(print Json_search.page)
     ~init:true
   >>= fun _ ->
   Format.fprintf output "]";

src/search/json_display.ml

@@ -0,0 +1,98 @@
+let json_of_id x =
+  `Array
+    (x |> Odoc_model.Paths.Identifier.fullname
+    |> List.map (fun str -> `String str))
+
+let json_of_doc (doc : Odoc_model.Comment.docs) =
+  let html = Render.html_of_doc doc in
+  `String (Format.asprintf "%a" (Tyxml.Html.pp_elt ()) html)
+
+let display_expression_rhs args res =
+  let open Odoc_model.Lang in
+  match res with
+  | Some res -> (
+      " : "
+      ^
+      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)
+  | None -> (
+      match args with
+      | TypeDecl.Constructor.Tuple args -> (
+          match args with
+          | _ :: _ :: _ -> " of " ^ Render.text_of_type (TypeExpr.Tuple args)
+          | [ arg ] -> " of " ^ Render.text_of_type arg
+          | _ -> "")
+      | TypeDecl.Constructor.Record fields ->
+          let fields = Render.text_of_record fields in
+          " of " ^ fields)
+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 of_entry ({ id; doc; extra } : Entry.t) : Odoc_html.Json.json =
+  let j_url = `String (Render.url id) in
+  let j_id = json_of_id id in
+  let doc = json_of_doc doc in
+  let kind =
+    `String
+      (match extra with
+      | TypeDecl _ -> "type"
+      | Module -> "module"
+      | Value _ -> "val"
+      | Doc _ -> "doc"
+      | Exception _ -> "exn"
+      | Class_type _ -> "class type"
+      | Method _ -> "method"
+      | Class _ -> "class"
+      | TypeExtension _ ->
+          (* TODO: include type_path and type_params *)
+          "type ext"
+      | ExtensionConstructor _ -> "extension constructor"
+      | ModuleType -> "module type"
+      | Constructor _ -> "constructor"
+      | Field _ -> "field")
+  in
+  let rhs =
+    match extra with
+    | TypeDecl { canonical = _; equation = _; representation = _; txt } ->
+        let segments = String.split_on_char '=' txt in
+        if List.length segments > 1 then
+          segments |> List.tl |> String.concat "=" |> String.trim |> ( ^ ) " = "
+          |> Option.some
+        else None
+    | Constructor { args; res } ->
+        Some (" : " ^ display_constructor_type args res)
+    | Field { mutable_ = _; type_; parent_type = _ } ->
+        Some (" : " ^ Render.text_of_type type_)
+    | Exception { args; res } -> Some (display_expression_rhs args res)
+    | Value { value = _; type_ } -> Some (" : " ^ Render.text_of_type type_)
+    | Module | Doc _ | Class_type _ | Method _ | Class _ | TypeExtension _
+    | ExtensionConstructor _ | ModuleType ->
+        None
+  in
+  `Object
+    ((match rhs with None -> [] | Some rhs -> [ ("rhs", `String rhs) ])
+    @ [ ("id", j_id); ("url", j_url); ("kind", kind); ("doc", doc) ])

src/search/json_display.mli

@@ -0,0 +1 @@
+val of_entry : Entry.t -> Odoc_html.Json.json

src/search/json_output.ml → src/search/json_search.ml

@@ -30,7 +30,7 @@ let json_of_args (args : Odoc_model.Lang.TypeDecl.Constructor.argument) =
                  fl) );
         ]
 
-let rec json_of_id x =
+let rec of_id x =
   let open Odoc_model.Names in
   let open Odoc_model.Paths.Identifier in
   let ret kind name =
@@ -41,45 +41,42 @@ let rec json_of_id x =
   | `Page (_, name) -> [ ret "Page" (PageName.to_string name) ]
   | `LeafPage (_, name) -> [ ret "Page" (PageName.to_string name) ]
   | `Module (parent, name) ->
-      ret "Module" (ModuleName.to_string name) :: json_of_id (parent :> t)
+      ret "Module" (ModuleName.to_string name) :: of_id (parent :> t)
   | `Parameter (parent, name) ->
-      ret "Parameter" (ModuleName.to_string name) :: json_of_id (parent :> t)
-  | `Result x -> json_of_id (x :> t)
+      ret "Parameter" (ModuleName.to_string name) :: of_id (parent :> t)
+  | `Result x -> of_id (x :> t)
   | `ModuleType (parent, name) ->
-      ret "ModuleType" (ModuleTypeName.to_string name)
-      :: json_of_id (parent :> t)
+      ret "ModuleType" (ModuleTypeName.to_string name) :: of_id (parent :> t)
   | `Type (parent, name) ->
-      ret "Type" (TypeName.to_string name) :: json_of_id (parent :> t)
+      ret "Type" (TypeName.to_string name) :: of_id (parent :> t)
   | `CoreType name -> [ ret "CoreType" (TypeName.to_string name) ]
   | `Constructor (parent, name) ->
-      ret "Constructor" (ConstructorName.to_string name)
-      :: json_of_id (parent :> t)
+      ret "Constructor" (ConstructorName.to_string name) :: of_id (parent :> t)
   | `Field (parent, name) ->
-      ret "Field" (FieldName.to_string name) :: json_of_id (parent :> t)
+      ret "Field" (FieldName.to_string name) :: of_id (parent :> t)
   | `Extension (parent, name) ->
-      ret "Extension" (ExtensionName.to_string name) :: json_of_id (parent :> t)
+      ret "Extension" (ExtensionName.to_string name) :: of_id (parent :> t)
   | `Exception (parent, name) ->
-      ret "Exception" (ExceptionName.to_string name) :: json_of_id (parent :> t)
+      ret "Exception" (ExceptionName.to_string name) :: of_id (parent :> t)
   | `CoreException name ->
       [ ret "CoreException" (ExceptionName.to_string name) ]
   | `Value (parent, name) ->
-      ret "Value" (ValueName.to_string name) :: json_of_id (parent :> t)
+      ret "Value" (ValueName.to_string name) :: of_id (parent :> t)
   | `Class (parent, name) ->
-      ret "Class" (ClassName.to_string name) :: json_of_id (parent :> t)
+      ret "Class" (ClassName.to_string name) :: of_id (parent :> t)
   | `ClassType (parent, name) ->
-      ret "ClassType" (ClassTypeName.to_string name) :: json_of_id (parent :> t)
+      ret "ClassType" (ClassTypeName.to_string name) :: of_id (parent :> t)
   | `Method (parent, name) ->
-      ret "Method" (MethodName.to_string name) :: json_of_id (parent :> t)
+      ret "Method" (MethodName.to_string name) :: of_id (parent :> t)
   | `InstanceVariable (parent, name) ->
       ret "InstanceVariable" (InstanceVariableName.to_string name)
-      :: json_of_id (parent :> t)
+      :: of_id (parent :> t)
   | `Label (parent, name) ->
-      ret "Label" (LabelName.to_string name) :: json_of_id (parent :> t)
+      ret "Label" (LabelName.to_string name) :: of_id (parent :> t)
 
-let json_of_id n =
-  `Array (List.rev @@ json_of_id (n :> Odoc_model.Paths.Identifier.t))
+let of_id n = `Array (List.rev @@ of_id (n :> Odoc_model.Paths.Identifier.t))
 
-let json_of_doc (doc : Odoc_model.Comment.docs) =
+let of_doc (doc : Odoc_model.Comment.docs) =
   let txt = Render.text_of_doc doc in
   let html = Render.html_of_doc doc in
   `Object
@@ -88,14 +85,15 @@ let json_of_doc (doc : Odoc_model.Comment.docs) =
       ("txt", `String txt);
     ]
 
-let json_of_entry ({ id; doc; extra } : Entry.t) : Odoc_html.Json.json =
+let of_entry ({ id; doc; extra } as entry : Entry.t) : Odoc_html.Json.json =
   let j_url = `String (Render.url id) in
-  let j_id = json_of_id id in
-  let doc = json_of_doc doc in
+  let j_id = of_id id in
+  let doc = of_doc doc in
+  let display = Json_display.of_entry entry in
   let extra =
     let return kind arr = `Object (("kind", `String kind) :: arr) in
     match extra with
-    | TypeDecl { canonical = _; equation; representation = _; txt } ->
+    | TypeDecl { canonical = _; equation; representation = _; txt=_ } ->
         let {
           Odoc_model.Lang.TypeDecl.Equation.params = _;
           private_;
@@ -121,20 +119,12 @@ let json_of_entry ({ id; doc; extra } : Entry.t) : Odoc_html.Json.json =
                    ])
                constraints)
         in
-        let segments = String.split_on_char '=' txt in
-        let rhs =
-          if List.length segments > 1 then
-            segments |> List.tl |> String.concat "=" |> String.trim
-            |> Option.some
-          else None
-        in
         return "TypeDecl"
-          ((match rhs with None -> [] | Some rhs -> [ ("type", `String rhs) ])
-          @ [
+          [
               ("private", private_);
               ("manifest", manifest);
               ("constraints", constraints);
-            ])
+            ]
     | Module -> return "Module" []
     | Value { value = _; type_ } ->
         return "Value" [ ("type", `String (Render.text_of_type type_)) ]
@@ -186,9 +176,14 @@ let json_of_entry ({ id; doc; extra } : Entry.t) : Odoc_html.Json.json =
             ("parent_type", `String (Render.text_of_type parent_type));
           ]
   in
-  `Object [ ("id", j_id); ("url", j_url); ("doc", doc); ("extra", extra) ]
-
-let string_of_entry entry = entry |> json_of_entry |> Odoc_html.Json.to_string
+  `Object
+    [
+      ("id", j_id);
+      ("url", j_url);
+      ("doc", doc);
+      ("extra", extra);
+      ("display", display);
+    ]
 
 let output_json ppf first entries =
   let output_json json =
@@ -197,7 +192,7 @@ let output_json ppf first entries =
   in
   List.fold_left
     (fun first entry ->
-      let json = json_of_entry entry in
+      let json = of_entry entry in
       if not first then Format.fprintf ppf ",";
       output_json json;
       false)

src/search/json_output.mli → src/search/json_search.mli

@@ -1,3 +1,4 @@
+(** This module generates json intended to be consumed by search engines. *)
+
 val unit : Format.formatter -> Odoc_model.Lang.Compilation_unit.t -> unit
 val page : Format.formatter -> Odoc_model.Lang.Page.t -> unit
-val string_of_entry : Entry.t -> string