diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 596cee6ab8..f1d69e1429 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -2,113 +2,173 @@ open Odoc_utils open Types module Id = Odoc_model.Paths.Identifier -let sidebar_toc_entry href content = - let target = Target.(Internal (Resolved href)) in - inline @@ Inline.Link { target; content; tooltip = None } - module Toc : sig type t val of_page_hierarchy : Odoc_index.Page_hierarchy.t -> t - val to_sidebar : - ?fallback:string -> (Url.t * Inline.one -> Block.one) -> t -> Block.t + val of_skeleton : Odoc_index.Skeleton.t -> t + + val to_block : prune:bool -> Url.Path.t -> t -> Block.t end = struct - type t = (Url.t * Inline.one) option Tree.t + type t = (Url.t option * Inline.one) Tree.t - let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) = + let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) : t = let f index = match index with - | None -> None - | Some (index_id, title) -> - let path = - Url.from_identifier ~stop_before:false (index_id :> Id.t) - in + | Odoc_index.Page_hierarchy.Missing_index None -> + (None, inline @@ Text "Root") + | Odoc_index.Page_hierarchy.Missing_index (Some id) -> + let path = Url.from_identifier ~stop_before:false (id :> Id.t) in + (Some path, inline @@ Text (Id.name id)) + | Page (id, title) -> + let path = Url.from_identifier ~stop_before:false (id :> Id.t) in let content = Comment.link_content title in - Some (path, sidebar_toc_entry path content) + let target = Target.Internal (Target.Resolved path) in + let i = inline @@ Inline.Link { target; content; tooltip = None } in + (Some path, i) in Tree.map ~f dir - let rec to_sidebar ?(fallback = "root") convert - { Tree.node = name; children = content } = - let name = - match name with - | Some v -> convert v - | None -> block (Block.Inline [ inline (Text fallback) ]) + let rec is_prefix (url1 : Url.Path.t) (url2 : Url.Path.t) = + if url1 = url2 then true + else + match url2 with + | { parent = Some parent; _ } -> is_prefix url1 parent + | { parent = None; _ } -> false + + let parent (url : Url.t) = + match url with + | { anchor = ""; page = { parent = Some parent; _ }; _ } -> parent + | { page; _ } -> page + + let to_block ~prune (current_url : Url.Path.t) (tree : t) = + let block_tree_of_t (current_url : Url.Path.t) (tree : t) = + (* When transforming the tree, we use a filter_map to remove the nodes that + are irrelevant for the current url. However, we always want to keep the + root. So we apply the filter_map starting from the first children. *) + let convert ((url : Url.t option), b) = + let link = + match url with + | Some url -> + if url.page = current_url && Astring.String.equal url.anchor "" + then { b with Inline.attr = [ "current_unit" ] } + else b + | None -> b + in + Types.block @@ Inline [ link ] + in + let f name = + match name with + | Some url, _ when prune && not (is_prefix (parent url) current_url) -> + None + | v -> Some (convert v) + in + let root_entry = convert tree.Tree.node in + { Tree.node = root_entry; children = Forest.filter_map ~f tree.children } + in + let rec block_of_block_tree { Tree.node = name; children = content } = + let content = + match content with + | [] -> [] + | _ :: _ -> + let content = List.map block_of_block_tree content in + [ block (Block.List (Block.Unordered, content)) ] + in + name :: content + in + let block_tree = block_tree_of_t current_url tree in + block_of_block_tree block_tree + + let of_skeleton ({ node = entry; children } : Odoc_index.Entry.t Tree.t) : t = + let map_entry entry = + let stop_before = + match entry.Odoc_index.Entry.kind with + | ModuleType { has_expansion } | Module { has_expansion } -> + not has_expansion + | _ -> false + in + let name = Odoc_model.Paths.Identifier.name entry.id in + let path = Url.from_identifier ~stop_before entry.id in + let content = + let target = Target.Internal (Resolved path) in + inline + (Link { target; content = [ inline (Text name) ]; tooltip = None }) + in + (Some path, content) in - let content = - match content with - | [] -> [] - | _ :: _ -> - let content = List.map (to_sidebar convert) content in - [ block (Block.List (Block.Unordered, content)) ] + let f entry = + match entry.Odoc_index.Entry.kind with + | Module _ | Class_type _ | Class _ | ModuleType _ -> + Some (map_entry entry) + | _ -> None in - name :: content + let entry = map_entry entry in + let children = Forest.filter_map ~f children in + { Tree.node = entry; children } end + type pages = { name : string; pages : Toc.t } -type library = { name : string; units : (Url.t * Inline.one) list } +type library = { name : string; units : Toc.t list } type t = { pages : pages list; libraries : library list } -let of_lang (v : Odoc_index.sidebar) = +let of_lang (v : Odoc_index.t) = + let { Odoc_index.pages; libs; extra = _ } = v in let pages = let page_hierarchy { Odoc_index.p_name; p_hierarchy } = let hierarchy = Toc.of_page_hierarchy p_hierarchy in - Some { name = p_name; pages = hierarchy } + { name = p_name; pages = hierarchy } in - Odoc_utils.List.filter_map page_hierarchy v.pages + Odoc_utils.List.map page_hierarchy pages in - let units = - let item id = - let content = [ inline @@ Text (Odoc_model.Paths.Identifier.name id) ] in - let path = Url.from_identifier ~stop_before:false (id :> Id.t) in - (path, sidebar_toc_entry path content) + let libraries = + let lib_hierarchies { Odoc_index.l_name; l_hierarchies } = + let hierarchies = List.map Toc.of_skeleton l_hierarchies in + { units = hierarchies; name = l_name } in - let units = - List.map - (fun { Odoc_index.units; name } -> - let units = List.map item units in - { name; units }) - v.libs - in - units + Odoc_utils.List.map lib_hierarchies libs in - { pages; libraries = units } + { pages; libraries } -let to_block (sidebar : t) url = +let to_block (sidebar : t) path = let { pages; libraries } = sidebar in - let title t = - block - (Inline [ inline (Inline.Styled (`Bold, [ inline (Inline.Text t) ])) ]) - in - let render_entry (entry_path, b) = - let link = - if entry_path = Url.from_path url then - { b with Inline.attr = [ "current_unit" ] } - else b - in - Types.block @@ Inline [ link ] - in + let title t = block (Inline [ inline (Inline.Styled (`Bold, t)) ]) in let pages = - Odoc_utils.List.concat_map - ~f:(fun (p : pages) -> - let pages = Toc.to_sidebar render_entry p.pages in - let pages = [ block (Block.List (Block.Unordered, [ pages ])) ] in - let pages = [ title @@ p.name ^ "'s Pages" ] @ pages in - pages) - pages + let pages = + Odoc_utils.List.concat_map + ~f:(fun (p : pages) -> + let () = ignore p.name in + let pages = Toc.to_block ~prune:false path p.pages in + [ + block ~attr:[ "odoc-pages" ] + (Block.List (Block.Unordered, [ pages ])); + ]) + pages + in + [ title @@ [ inline (Inline.Text "Documentation") ] ] @ pages in let units = let units = List.map (fun { units; name } -> + let units = + List.concat_map ~f:(Toc.to_block ~prune:true path) units + in + let units = [ block (Block.List (Block.Unordered, [ units ])) ] in [ - title name; - block (List (Block.Unordered, [ List.map render_entry units ])); - ]) + title + @@ [ + inline (Inline.Text "Library "); + inline (Inline.Source [ Elt [ inline @@ Text name ] ]); + ]; + ] + @ units) libraries in - let units = block (Block.List (Block.Unordered, units)) in - [ title "Libraries"; units ] + let units = + block ~attr:[ "odoc-modules" ] (Block.List (Block.Unordered, units)) + in + [ units ] in - pages @ units + units @ pages diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli index 20b1fe6714..eecb0c8c15 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,6 +1,6 @@ type t -val of_lang : Odoc_index.sidebar -> t +val of_lang : Odoc_index.t -> t val to_block : t -> Url.Path.t -> Types.Block.t (** Generates the sidebar document given a global sidebar and the path at which diff --git a/src/index/entry.ml b/src/index/entry.ml index 5f597e9cab..601af8daf5 100644 --- a/src/index/entry.ml +++ b/src/index/entry.ml @@ -1,6 +1,8 @@ open Odoc_model.Lang open Odoc_model.Paths +module Html = Tyxml.Html + type type_decl_entry = { canonical : Path.Type.t option; equation : TypeDecl.Equation.t; @@ -36,27 +38,25 @@ type instance_variable_entry = { type_ : TypeExpr.t; } -type doc_entry = Paragraph | Heading | CodeBlock | MathBlock | Verbatim - type value_entry = { value : Value.value; type_ : TypeExpr.t } +type module_entry = { has_expansion : bool } + type kind = | TypeDecl of type_decl_entry - | Module + | Module of module_entry | Value of value_entry - | Doc of doc_entry + | Doc | Exception of constructor_entry | Class_type of class_type_entry | Method of method_entry | Class of class_entry | TypeExtension of type_extension_entry | ExtensionConstructor of constructor_entry - | ModuleType + | ModuleType of module_entry | Constructor of constructor_entry | Field of field_entry -module Html = Tyxml.Html - type t = { id : Odoc_model.Paths.Identifier.Any.t; doc : Odoc_model.Comment.docs; @@ -66,154 +66,3 @@ type t = { let entry ~id ~doc ~kind = let id = (id :> Odoc_model.Paths.Identifier.Any.t) in { id; kind; doc } - -let varify_params = - List.mapi (fun i param -> - match param.TypeDecl.desc with - | Var name -> TypeExpr.Var name - | Any -> Var (Printf.sprintf "tv_%i" i)) - -let entry_of_constructor id_parent params (constructor : TypeDecl.Constructor.t) - = - let args = constructor.args in - let res = - match constructor.res with - | Some res -> res - | None -> - let params = varify_params params in - TypeExpr.Constr - ( `Identifier - ((id_parent :> Odoc_model.Paths.Identifier.Path.Type.t), false), - params ) - in - 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 args = constructor.args in - let res = - match constructor.res with - | Some res -> res - | None -> - let params = varify_params params in - TypeExpr.Constr (id_parent, params) - in - 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 - let parent_type = - TypeExpr.Constr - ( `Identifier - ((id_parent :> Odoc_model.Paths.Identifier.Path.Type.t), false), - params ) - in - let kind = - Field { mutable_ = field.mutable_; type_ = field.type_; parent_type } - in - entry ~id:field.id ~doc:field.doc ~kind - -let rec entries_of_docs id (d : Odoc_model.Comment.docs) = - Odoc_utils.List.concat_map ~f:(entries_of_doc id) d - -and entries_of_doc id d = - match d.value with - | `Paragraph _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc Paragraph) ] - | `Tag _ -> [] - | `List (_, ds) -> - Odoc_utils.List.concat_map ~f:(entries_of_docs id) - (ds :> Odoc_model.Comment.docs list) - | `Heading (_, lbl, _) -> [ entry ~id:lbl ~doc:[ d ] ~kind:(Doc Heading) ] - | `Modules _ -> [] - | `Code_block (_, _, o) -> - let o = - match o with - | None -> [] - | Some o -> entries_of_docs id (o :> Odoc_model.Comment.docs) - in - entry ~id ~doc:[ d ] ~kind:(Doc CodeBlock) :: o - | `Verbatim _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc Verbatim) ] - | `Math_block _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc MathBlock) ] - | `Table _ -> [] - | `Media _ -> [] - -let entries_of_item (x : Fold.item) = - match x with - | CompilationUnit u -> ( - match u.content with - | Module m -> [ entry ~id:u.id ~doc:m.doc ~kind:Module ] - | Pack _ -> []) - | TypeDecl td -> - let kind = - TypeDecl - { - canonical = td.canonical; - equation = td.equation; - representation = td.representation; - } - in - let td_entry = entry ~id:td.id ~doc:td.doc ~kind in - let subtype_entries = - match td.representation with - | None -> [] - | Some (Variant li) -> - List.map (entry_of_constructor td.id td.equation.params) li - | Some (Record fields) -> - List.map (entry_of_field td.id td.equation.params) fields - | Some Extensible -> [] - in - td_entry :: subtype_entries - | Module m -> [ entry ~id:m.id ~doc:m.doc ~kind:Module ] - | Value v -> - let kind = Value { value = v.value; type_ = v.type_ } in - [ entry ~id:v.id ~doc:v.doc ~kind ] - | Exception exc -> - let res = - match exc.res with - | None -> - TypeExpr.Constr - ( `Resolved (`CoreType (Odoc_model.Names.TypeName.make_std "exn")), - [] ) - | Some x -> x - in - let kind = Exception { args = exc.args; res } in - [ entry ~id:exc.id ~doc:exc.doc ~kind ] - | ClassType ct -> - let kind = Class_type { virtual_ = ct.virtual_; params = ct.params } in - [ entry ~id:ct.id ~doc:ct.doc ~kind ] - | Method m -> - let kind = - Method { virtual_ = m.virtual_; private_ = m.private_; type_ = m.type_ } - in - [ entry ~id:m.id ~doc:m.doc ~kind ] - | Class cl -> - let kind = Class { virtual_ = cl.virtual_; params = cl.params } in - [ entry ~id:cl.id ~doc:cl.doc ~kind ] - | Extension te -> ( - match te.constructors with - | [] -> [] - | c :: _ -> - (* Type extension do not have an ID yet... we use the first - constructor for the url. Unfortunately, this breaks the uniqueness - of the ID in the search index... *) - let type_entry = - let kind = - TypeExtension - { - type_path = te.type_path; - type_params = te.type_params; - private_ = te.private_; - } - in - 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 ~kind:ModuleType ] - | Doc (_, `Stop) -> [] - | Doc (id, `Docs d) -> entries_of_docs id d diff --git a/src/index/entry.mli b/src/index/entry.mli index 4415a0d49e..198c8fc68e 100644 --- a/src/index/entry.mli +++ b/src/index/entry.mli @@ -36,22 +36,22 @@ type instance_variable_entry = { type_ : TypeExpr.t; } -type doc_entry = Paragraph | Heading | CodeBlock | MathBlock | Verbatim - type value_entry = { value : Value.value; type_ : TypeExpr.t } +type module_entry = { has_expansion : bool } + type kind = | TypeDecl of type_decl_entry - | Module + | Module of module_entry | Value of value_entry - | Doc of doc_entry + | Doc | Exception of constructor_entry | Class_type of class_type_entry | Method of method_entry | Class of class_entry | TypeExtension of type_extension_entry | ExtensionConstructor of constructor_entry - | ModuleType + | ModuleType of module_entry | Constructor of constructor_entry | Field of field_entry @@ -61,4 +61,8 @@ type t = { kind : kind; } -val entries_of_item : Fold.item -> t list +val entry : + id:[< Odoc_model.Paths.Identifier.Any.t_pv ] Odoc_model.Paths.Identifier.id -> + doc:Odoc_model.Comment.docs -> + kind:kind -> + t diff --git a/src/index/fold.ml b/src/index/fold.ml deleted file mode 100644 index 9fa77dc003..0000000000 --- a/src/index/fold.ml +++ /dev/null @@ -1,138 +0,0 @@ -open Odoc_model -open Lang - -type item = - | CompilationUnit of Compilation_unit.t - | TypeDecl of TypeDecl.t - | Module of Module.t - | Value of Value.t - | Exception of Exception.t - | ClassType of ClassType.t - | Method of Method.t - | Class of Class.t - | Extension of Extension.t - | ModuleType of ModuleType.t - | Doc of Paths.Identifier.LabelParent.t * Comment.docs_or_stop - -let rec unit ~f acc u = - let acc = f acc (CompilationUnit u) in - match u.content with - | Module m -> signature ~f (u.id :> Paths.Identifier.LabelParent.t) acc m - | Pack _ -> acc - -and page ~f acc p = - let open Page in - docs ~f (p.name :> Paths.Identifier.LabelParent.t) acc (`Docs p.content) - -and signature ~f id acc (s : Signature.t) = - List.fold_left - (signature_item ~f (id :> Paths.Identifier.LabelParent.t)) - acc s.items - -and signature_item ~f id acc s_item = - match s_item with - | Module (_, m) -> module_ ~f (m.id :> Paths.Identifier.LabelParent.t) acc m - | ModuleType mt -> - module_type ~f (mt.id :> Paths.Identifier.LabelParent.t) acc mt - | ModuleSubstitution _ -> acc - | ModuleTypeSubstitution _ -> acc - | Open _ -> acc - | Type (_, t_decl) -> type_decl ~f acc t_decl - | TypeSubstitution _ -> acc - | TypExt te -> type_extension ~f acc te - | Exception exc -> exception_ ~f acc exc - | Value v -> value ~f acc v - | Class (_, cl) -> class_ ~f (cl.id :> Paths.Identifier.LabelParent.t) acc cl - | ClassType (_, clt) -> - class_type ~f (clt.id :> Paths.Identifier.LabelParent.t) acc clt - | Include i -> include_ ~f id acc i - | Comment d -> docs ~f id acc d - -and docs ~f id acc d = f acc (Doc (id, d)) - -and include_ ~f id acc inc = signature ~f id acc inc.expansion.content - -and class_type ~f id acc ct = - (* This check is important because [is_internal] does not work on children of - internal items. This means that if [Fold] did not make this check here, - it would be difficult to filter for internal items afterwards. This also - applies to the same check in functions bellow. *) - if Paths.Identifier.is_hidden ct.id then acc - else - let acc = f acc (ClassType ct) in - match ct.expansion with - | None -> acc - | Some cs -> class_signature ~f id acc cs - -and class_signature ~f id acc ct_expr = - List.fold_left (class_signature_item ~f id) acc ct_expr.items - -and class_signature_item ~f id acc item = - match item with - | Method m -> f acc (Method m) - | InstanceVariable _ -> acc - | Constraint _ -> acc - | Inherit _ -> acc - | Comment d -> docs ~f id acc d - -and class_ ~f id acc cl = - if Paths.Identifier.is_hidden cl.id then acc - else - let acc = f acc (Class cl) in - match cl.expansion with - | None -> acc - | Some cl_signature -> class_signature ~f id acc cl_signature - -and exception_ ~f acc exc = - if Paths.Identifier.is_hidden exc.id then acc else f acc (Exception exc) - -and type_extension ~f acc te = f acc (Extension te) - -and value ~f acc v = - if Paths.Identifier.is_hidden v.id then acc else f acc (Value v) - -and module_ ~f id acc m = - if Paths.Identifier.is_hidden m.id then acc - else - let acc = f acc (Module m) in - match m.type_ with - | Alias (_, None) -> acc - | Alias (_, Some s_e) -> simple_expansion ~f id acc s_e - | ModuleType mte -> module_type_expr ~f id acc mte - -and type_decl ~f acc td = - if Paths.Identifier.is_hidden td.id then acc else f acc (TypeDecl td) - -and module_type ~f id acc mt = - if Paths.Identifier.is_hidden mt.id then acc - else - let acc = f acc (ModuleType mt) in - match mt.expr with - | None -> acc - | Some mt_expr -> module_type_expr ~f id acc mt_expr - -and simple_expansion ~f id acc s_e = - match s_e with - | Signature sg -> signature ~f id acc sg - | Functor (p, s_e) -> - let acc = functor_parameter ~f acc p in - simple_expansion ~f id acc s_e - -and module_type_expr ~f id acc mte = - match mte with - | Signature s -> signature ~f id acc s - | Functor (fp, mt_expr) -> - let acc = functor_parameter ~f acc fp in - module_type_expr ~f id acc mt_expr - | With { w_expansion = Some sg; _ } -> simple_expansion ~f id acc sg - | TypeOf { t_expansion = Some sg; _ } -> simple_expansion ~f id acc sg - | Path { p_expansion = Some sg; _ } -> simple_expansion ~f id acc sg - | Path { p_expansion = None; _ } -> acc - | With { w_expansion = None; _ } -> acc - | TypeOf { t_expansion = None; _ } -> acc - -and functor_parameter ~f acc fp = - match fp with - | Unit -> acc - | Named n -> - module_type_expr ~f (n.id :> Paths.Identifier.LabelParent.t) acc n.expr diff --git a/src/index/fold.mli b/src/index/fold.mli deleted file mode 100644 index 2df70e3a29..0000000000 --- a/src/index/fold.mli +++ /dev/null @@ -1,100 +0,0 @@ -(** This module allows to fold over odoc values. It is notably used to construct - a search database of every relevant item. It appear to be very generic but - in reality it is quite specialized to fold over searchable items, and not - every kind of odoc value you could fold over.*) - -open Odoc_model -open Lang - -(** The type of items you can fold over *) -type item = - | CompilationUnit of Compilation_unit.t - | TypeDecl of TypeDecl.t - | Module of Module.t - | Value of Value.t - | Exception of Exception.t - | ClassType of ClassType.t - | Method of Method.t - | Class of Class.t - | Extension of Extension.t - | ModuleType of ModuleType.t - | Doc of Paths.Identifier.LabelParent.t * Comment.docs_or_stop - -(** Below are the folding functions. For items that may contain - others, such as [signature], it folds recursively on the - sub-items. It does not recurse into internal items. - - The LabelParent identifier is used to give an id to the doc entries. *) - -val unit : f:('a -> item -> 'a) -> 'a -> Compilation_unit.t -> 'a -val page : f:('a -> item -> 'a) -> 'a -> Page.t -> 'a - -val signature : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - Signature.t -> - 'a -val signature_item : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - Signature.item -> - 'a -val docs : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - Comment.docs_or_stop -> - 'a -val include_ : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - Include.t -> - 'a -val class_type : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - ClassType.t -> - 'a -val class_signature : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - ClassSignature.t -> - 'a -val class_signature_item : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - ClassSignature.item -> - 'a -val class_ : - f:('a -> item -> 'a) -> Paths.Identifier.LabelParent.t -> 'a -> Class.t -> 'a -val exception_ : f:('a -> item -> 'a) -> 'a -> Exception.t -> 'a -val type_extension : f:('a -> item -> 'a) -> 'a -> Extension.t -> 'a -val value : f:('a -> item -> 'a) -> 'a -> Value.t -> 'a -val module_ : - f:('a -> item -> 'a) -> Paths.Identifier.LabelParent.t -> 'a -> Module.t -> 'a -val type_decl : f:('a -> item -> 'a) -> 'a -> TypeDecl.t -> 'a -val module_type : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - ModuleType.t -> - 'a -val simple_expansion : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - ModuleType.simple_expansion -> - 'a -val module_type_expr : - f:('a -> item -> 'a) -> - Paths.Identifier.LabelParent.t -> - 'a -> - ModuleType.expr -> - 'a -val functor_parameter : f:('a -> item -> 'a) -> 'a -> FunctorParameter.t -> 'a diff --git a/src/index/odoc_index.ml b/src/index/odoc_index.ml index 5fac95548f..2ba4634479 100644 --- a/src/index/odoc_index.ml +++ b/src/index/odoc_index.ml @@ -1,17 +1,16 @@ +module Skeleton = Skeleton module Entry = Entry -module Fold = Fold module Page_hierarchy = Page_hierarchy type page = { p_name : string; p_hierarchy : Page_hierarchy.t } -type library = { - name : string; - units : Odoc_model.Paths.Identifier.RootModule.t list; -} - -type sidebar = { pages : page list; libs : library list } +type lib_hierarchies = Skeleton.t list +type lib = { l_name : string; l_hierarchies : lib_hierarchies } -type 'a t = { - sidebar : sidebar; - index : 'a Odoc_model.Paths.Identifier.Hashtbl.Any.t; +type t = { + pages : page list; + libs : lib list; + extra : Skeleton.t list; + (** This extra table is used only for search. It was introduced before + Odoc 3 *) } diff --git a/src/index/page_hierarchy.ml b/src/index/page_hierarchy.ml index 2d6d65ee6a..1784f4c03a 100644 --- a/src/index/page_hierarchy.ml +++ b/src/index/page_hierarchy.ml @@ -75,16 +75,18 @@ let dir_index ((parent_id, _) as dir) = | Some payload -> Some (payload, index_id, payload.title) | None -> None -type index = Id.Page.t * title +type index = + | Page of Id.Page.t * title + | Missing_index of Id.ContainerPage.t option -type t = index option Odoc_utils.Tree.t +type t = index Odoc_utils.Tree.t let rec t_of_in_progress (dir : in_progress) : t = let children_order, index = match dir_index dir with | Some ({ children_order; _ }, index_id, index_title) -> - (children_order, Some (index_id, index_title)) - | None -> (None, None) + (children_order, Page (index_id, index_title)) + | None -> (None, Missing_index (fst dir)) in let pp_content fmt (id, _) = match id.Id.iv with @@ -102,7 +104,7 @@ let rec t_of_in_progress (dir : in_progress) : t = leafs dir |> List.map (fun (id, payload) -> let id :> Id.Page.t = id in - (id, Tree.leaf (Some (id, payload)))) + (id, Tree.leaf (Page (id, payload)))) in let dirs = dirs dir @@ -181,7 +183,7 @@ let rec t_of_in_progress (dir : in_progress) : t = let rec remove_common_root (v : t) = match v with - | { Tree.children = [ v ]; node = None } -> remove_common_root v + | { Tree.children = [ v ]; node = Missing_index _ } -> remove_common_root v | _ -> v let of_list l = diff --git a/src/index/page_hierarchy.mli b/src/index/page_hierarchy.mli index 21cc2077c4..d24f8287bc 100644 --- a/src/index/page_hierarchy.mli +++ b/src/index/page_hierarchy.mli @@ -6,9 +6,11 @@ open Odoc_utils type title = Comment.link_content -type index = Identifier.Page.t * title +type index = + | Page of Paths.Identifier.Page.t * title + | Missing_index of Paths.Identifier.ContainerPage.t option -type t = index option Tree.t +type t = index Tree.t val of_list : (Identifier.LeafPage.t * title * Frontmatter.children_order option) list -> t diff --git a/src/index/skeleton.ml b/src/index/skeleton.ml new file mode 100644 index 0000000000..cf1c946293 --- /dev/null +++ b/src/index/skeleton.ml @@ -0,0 +1,275 @@ +open Odoc_model.Lang +open Odoc_model.Paths + +open Odoc_utils + +type t = Entry.t Tree.t + +module Entry = struct + let of_comp_unit (u : Compilation_unit.t) = + let has_expansion = true in + let doc = match u.content with Pack _ -> [] | Module m -> m.doc in + Entry.entry ~id:u.id ~doc ~kind:(Module { has_expansion }) + + 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 ~kind:(Module { has_expansion }) + + let of_module_type (mt : ModuleType.t) = + let has_expansion = + match mt.expr with + | Some expr -> ( + match expr with + | Signature _ -> true + | Functor _ -> true + | Path { p_expansion = Some _; _ } -> true + | With { w_expansion = Some _; _ } -> true + | TypeOf { t_expansion = Some _; _ } -> true + | _ -> false) + | _ -> true + in + Entry.entry ~id:mt.id ~doc:mt.doc ~kind:(ModuleType { has_expansion }) + + let of_type_decl (td : TypeDecl.t) = + let kind = + Entry.TypeDecl + { + canonical = td.canonical; + equation = td.equation; + representation = td.representation; + } + in + let td_entry = Entry.entry ~id:td.id ~doc:td.doc ~kind in + td_entry + + let varify_params = + List.mapi (fun i param -> + match param.TypeDecl.desc with + | Var name -> TypeExpr.Var name + | Any -> Var (Printf.sprintf "tv_%i" i)) + + let of_constructor id_parent params (c : TypeDecl.Constructor.t) = + let args = c.args in + let res = + match c.res with + | Some res -> res + | None -> + let params = varify_params params in + TypeExpr.Constr + ( `Identifier + ((id_parent :> Odoc_model.Paths.Identifier.Path.Type.t), false), + params ) + in + let kind = Entry.Constructor { args; res } in + Entry.entry ~id:c.id ~doc:c.doc ~kind + + let of_field id_parent params (field : TypeDecl.Field.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.Field + { mutable_ = field.mutable_; type_ = field.type_; parent_type } + in + Entry.entry ~id:field.id ~doc:field.doc ~kind + + let of_exception (exc : Exception.t) = + let res = + match exc.res with + | None -> + TypeExpr.Constr + ( `Resolved (`CoreType (Odoc_model.Names.TypeName.make_std "exn")), + [] ) + | Some x -> x + in + let kind = Entry.Exception { args = exc.args; res } in + Entry.entry ~id:exc.id ~doc:exc.doc ~kind + + 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 ~kind + + 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 ~kind + + 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 ~kind + + 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 ~kind + + let of_docs id doc = Entry.entry ~id ~doc ~kind:Doc +end + +let if_non_hidden id f = + if Identifier.is_hidden (id :> Identifier.t) then [] else f () + +let rec unit (u : Compilation_unit.t) = + let entry = Entry.of_comp_unit u in + let children = + match u.content with + | Pack _ -> [] + | Module m -> signature (u.id :> Identifier.LabelParent.t) m + in + { Tree.node = entry; children } + +and signature id (s : Signature.t) = + List.concat_map ~f:(signature_item (id :> Identifier.LabelParent.t)) s.items + +and signature_item id s_item = + match s_item with + | Module (_, m) -> module_ (m.id :> Identifier.LabelParent.t) m + | ModuleType mt -> module_type (mt.id :> Identifier.LabelParent.t) mt + | ModuleSubstitution _ -> [] + | ModuleTypeSubstitution _ -> [] + | Open _ -> [] + | Type (_, t_decl) -> type_decl t_decl + | TypeSubstitution _ -> [] + | TypExt _te -> [] + | Exception exc -> exception_ exc + | Value v -> value v + | Class (_, cl) -> class_ (cl.id :> Identifier.LabelParent.t) cl + | ClassType (_, clt) -> class_type (clt.id :> Identifier.LabelParent.t) clt + | Include i -> include_ id i + | Comment d -> docs id d + +and module_ id m = + if_non_hidden m.id @@ fun () -> + let entry = Entry.of_module m in + let children = + match m.type_ with + | Alias (_, None) -> [] + | Alias (_, Some s_e) -> simple_expansion id s_e + | ModuleType mte -> module_type_expr id mte + in + [ { Tree.node = entry; children } ] + +and module_type id mt = + if_non_hidden mt.id @@ fun () -> + let entry = Entry.of_module_type mt in + let children = + match mt.expr with + | None -> [] + | Some mt_expr -> module_type_expr id mt_expr + in + [ { Tree.node = entry; children } ] + +and type_decl td = + if_non_hidden td.id @@ fun () -> + let entry = Entry.of_type_decl td in + let children = + match td.representation with + | None -> [] + | Some (Variant cl) -> + List.concat_map ~f:(constructor td.id td.equation.params) cl + | Some (Record fl) -> List.concat_map ~f:(field td.id td.equation.params) fl + | Some Extensible -> [] + in + [ { Tree.node = entry; children } ] + +and constructor type_id params c = + let entry = Entry.of_constructor type_id params c in + [ Tree.leaf entry ] + +and field type_id params f = + let entry = Entry.of_field type_id params f in + [ Tree.leaf entry ] + +and _type_extension _te = [] + +and exception_ exc = + if_non_hidden exc.id @@ fun () -> + let entry = Entry.of_exception exc in + [ Tree.leaf entry ] + +and value v = + if_non_hidden v.id @@ fun () -> + let entry = Entry.of_value v in + [ Tree.leaf entry ] + +and class_ id cl = + if_non_hidden cl.id @@ fun () -> + let entry = Entry.of_class cl in + let children = + match cl.expansion with + | None -> [] + | Some cl_signature -> class_signature id cl_signature + in + [ { Tree.node = entry; children } ] + +and class_type id ct = + if_non_hidden ct.id @@ fun () -> + let entry = Entry.of_class_type ct in + let children = + match ct.expansion with None -> [] | Some cs -> class_signature id cs + in + [ { Tree.node = entry; children } ] + +and include_ id inc = signature id inc.expansion.content + +and docs id d = + match d with + | `Stop -> [] + | `Docs d -> + let entry = Entry.of_docs id d in + [ Tree.leaf entry ] + +and simple_expansion id s_e = + match s_e with + | Signature sg -> signature id sg + | Functor (p, s_e) -> + let _extra_entries = functor_parameter p in + simple_expansion id s_e + +and module_type_expr id mte = + match mte with + | Signature s -> signature id s + | Functor (fp, mt_expr) -> + let _extra_entries = functor_parameter fp in + module_type_expr id mt_expr + | 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 + | Path { p_expansion = None; _ } -> [] + | With { w_expansion = None; _ } -> [] + | TypeOf { t_expansion = None; _ } -> [] + +and class_signature id ct_expr = + List.concat_map ~f:(class_signature_item id) ct_expr.items + +and class_signature_item id item = + match item with + | Method m -> + let entry = Entry.of_method m in + [ Tree.leaf entry ] + | InstanceVariable _ -> [] + | Constraint _ -> [] + | Inherit _ -> [] + | Comment d -> docs id d + +and functor_parameter fp = + match fp with + | Unit -> [] + | Named n -> module_type_expr (n.id :> Identifier.LabelParent.t) n.expr + +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 + Tree.leaf entry diff --git a/src/index/skeleton.mli b/src/index/skeleton.mli new file mode 100644 index 0000000000..fcaea85b40 --- /dev/null +++ b/src/index/skeleton.mli @@ -0,0 +1,12 @@ +open Odoc_model.Lang +open Odoc_utils + +(** Skeletons represent a hierarchy of entries. It contains the least + information to create an index, represented in a uniform way (compared to + the [Lang] types) *) + +type t = Entry.t Tree.t + +val from_unit : Compilation_unit.t -> t + +val from_page : Page.t -> t diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index c643b631bb..efb848912b 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -5,11 +5,13 @@ open Or_error open Odoc_model module H = Odoc_model.Paths.Identifier.Hashtbl.Any +module Id = Odoc_model.Paths.Identifier let handle_file file ~unit ~page ~occ = match Fpath.basename file with | s when String.is_prefix ~affix:"index-" s -> - Odoc_file.load_index file >>= fun { index; _ } -> Ok (occ index) + Odoc_file.load_index file >>= fun { extra (* libs *); _ } -> + Ok (occ extra) | _ -> ( Odoc_file.load file >>= fun unit' -> match unit' with @@ -73,45 +75,73 @@ let compile_to_json ~output ~occurrences files = Format.fprintf output "]"; Ok () -let compile_to_marshall ~output sidebar files = - let final_index = H.create 10 in - let unit u = - Odoc_index.Fold.unit - ~f:(fun () item -> - let entries = Odoc_index.Entry.entries_of_item item in - List.iter - (fun entry -> H.add final_index entry.Odoc_index.Entry.id entry) - entries) - () u - in - let page p = - Odoc_index.Fold.page - ~f:(fun () item -> - let entries = Odoc_index.Entry.entries_of_item item in - List.iter - (fun entry -> H.add final_index entry.Odoc_index.Entry.id entry) - entries) - () p - in - let index i = H.iter (H.add final_index) i in - let () = - List.fold_left - (fun acc file -> +let compile_to_marshall ~output (pages, libs) files = + let unit u = [ Odoc_index.Skeleton.from_unit u ] in + let page p = [ Odoc_index.Skeleton.from_page p ] in + let index i = i in + let extra = + List.concat_map + ~f:(fun file -> match handle_file ~unit ~page ~occ:index file with - | Ok acc -> acc + | Ok l -> l | Error (`Msg m) -> Error.raise_warning ~non_fatal:true (Error.filename_only "%s" m (Fs.File.to_string file)); - acc) - () files + []) + files in - Ok (Odoc_file.save_index output { index = final_index; sidebar }) + let content = { Odoc_index.pages; libs; extra } in + Ok (Odoc_file.save_index output content) let read_occurrences file = let ic = open_in_bin file in let htbl : Odoc_occurrences.Table.t = Marshal.from_channel ic in htbl +let pages resolver page_roots = + List.map + (fun (page_root, _) -> + let pages = Resolver.all_pages ~root:page_root resolver in + let p_hierarchy = + let page_toc_input = + (* To create a page toc, we need a list with id, title and children + order. We generate this list from *) + let prepare_input (id, title, frontmatter) = + (* We filter non-leaf pages *) + match id with + | { Id.iv = #Id.LeafPage.t_pv; _ } as id -> + (* We generate a title if needed *) + let title = + match title with + | None -> Location_.[ at (span []) (`Word (Id.name id)) ] + | Some x -> x + in + let children_order = frontmatter.Frontmatter.children_order in + Some (id, title, children_order) + | _ -> None + in + List.filter_map prepare_input pages + in + Odoc_index.Page_hierarchy.of_list page_toc_input + in + { Odoc_index.p_name = page_root; p_hierarchy }) + page_roots + +let libs resolver lib_roots = + List.map + (fun (library, _) -> + let units = Resolver.all_units ~library resolver in + let l_hierarchies = + List.filter_map + (fun (file, _id) -> + match file () with + | Some unit -> Some (Odoc_index.Skeleton.from_unit unit) + | None -> None) + units + in + { Odoc_index.l_name = library; l_hierarchies }) + lib_roots + let compile out_format ~output ~warnings_options ~occurrences ~lib_roots ~page_roots ~inputs_in_file ~odocls = let handle_warnings f = @@ -127,59 +157,6 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots | None -> None | Some occurrences -> Some (read_occurrences (Fpath.to_string occurrences)) in - let resolver = - Resolver.create ~important_digests:false ~directories:[] - ~roots: - (Some - { - page_roots; - lib_roots; - current_lib = None; - current_package = None; - current_dir; - }) - ~open_modules:[] - in - (* if files = [] && then Error (`Msg "No .odocl files were included") *) - (* else *) - let pages = - List.map - (fun (page_root, _) -> - let pages = Resolver.all_pages ~root:page_root resolver in - let p_hierarchy = - let pages = - pages - |> List.filter_map - Paths.Identifier.( - function - | ({ iv = #LeafPage.t_pv; _ } as id), pl, fm -> - Some (id, pl, fm) - | _ -> None) - |> List.map (fun (id, title, fm) -> - let title = - match title with - | None -> - [ - Location_.at (Location_.span []) - (`Word (Paths.Identifier.name id)); - ] - | Some x -> x - in - let children_order = fm.Frontmatter.children_order in - (id, title, children_order)) - in - Odoc_index.Page_hierarchy.of_list pages - in - { Odoc_index.p_name = page_root; p_hierarchy }) - page_roots - in - let libs = - List.map - (fun (library, _) -> - let units = Resolver.all_units ~library resolver in - { Odoc_index.name = library; units }) - lib_roots - in let includes_rec = List.rev_append (List.map snd page_roots) (List.map snd lib_roots) in @@ -192,7 +169,22 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots [] include_rec) |> List.concat) in - let content = { Odoc_index.pages; libs } in match out_format with | `JSON -> compile_to_json ~output ~occurrences files - | `Marshall -> compile_to_marshall ~output content files + | `Marshall -> + let resolver = + Resolver.create ~important_digests:false ~directories:[] + ~roots: + (Some + { + page_roots; + lib_roots; + current_lib = None; + current_package = None; + current_dir; + }) + ~open_modules:[] + in + let pages = pages resolver page_roots in + let libs = libs resolver lib_roots in + compile_to_marshall ~output (pages, libs) files diff --git a/src/odoc/indexing.mli b/src/odoc/indexing.mli index d484fbd730..2103b58f6a 100644 --- a/src/odoc/indexing.mli +++ b/src/odoc/indexing.mli @@ -4,7 +4,7 @@ val handle_file : Fpath.t -> unit:(Odoc_model.Lang.Compilation_unit.t -> 'a) -> page:(Odoc_model.Lang.Page.t -> 'a) -> - occ:(Odoc_index.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> 'a) -> + occ:(Odoc_index.Skeleton.t list -> 'a) -> ('a, [> msg ]) result (** This function is exposed for custom indexers that uses [odoc] as a library to generate their search index *) diff --git a/src/odoc/odoc_file.mli b/src/odoc/odoc_file.mli index 5bd610f921..0f6c076efe 100644 --- a/src/odoc/odoc_file.mli +++ b/src/odoc/odoc_file.mli @@ -51,9 +51,9 @@ val load : Fs.File.t -> (t, [> msg ]) result val load_root : Fs.File.t -> (Root.t, [> msg ]) result (** Only load the root. Faster than {!load}, used for looking up imports. *) -val save_index : Fs.File.t -> Odoc_index.Entry.t Odoc_index.t -> unit +val save_index : Fs.File.t -> Odoc_index.t -> unit -val load_index : Fs.File.t -> (Odoc_index.Entry.t Odoc_index.t, [> msg ]) result +val load_index : Fs.File.t -> (Odoc_index.t, [> msg ]) result (** Load a [.odoc-index] file. *) val save_asset : Fpath.t -> warnings:Error.t list -> Lang.Asset.t -> unit diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index 2cb9208772..173562805f 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -69,8 +69,8 @@ let generate_odoc ~syntax ~warnings_options:_ ~renderer ~output ~extra_suffix (match sidebar with | None -> Ok None | Some x -> - Odoc_file.load_index x >>= fun { sidebar; index = _ } -> - Ok (Some (Odoc_document.Sidebar.of_lang sidebar))) + Odoc_file.load_index x >>= fun index -> + Ok (Some (Odoc_document.Sidebar.of_lang index))) >>= fun sidebar -> document_of_odocl ~syntax file >>= fun doc -> render_document renderer ~output ~sidebar ~extra_suffix ~extra doc; diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml index e011f4782a..6420e2350e 100644 --- a/src/odoc/resolver.ml +++ b/src/odoc/resolver.ml @@ -504,14 +504,16 @@ let all_roots ?root named_roots = | Ok x -> x | Error (NoPackage | NoRoot) -> [] in - let load page = - match Odoc_file.load_root page with Error _ -> None | Ok root -> Some root + let load file = + match Odoc_file.load_root file with + | Error _ -> None + | Ok root -> Some (file, root) in Odoc_utils.List.filter_map load all_files let all_pages ?root ({ pages; _ } : t) = - let filter (root : Odoc_model.Root.t) = - match root with + let filter (root : _ * Odoc_model.Root.t) = + match snd root with | { file = Page { title; frontmatter; _ }; id = { iv = #Odoc_model.Paths.Identifier.Page.t_pv; _ } as id; @@ -525,14 +527,21 @@ let all_pages ?root ({ pages; _ } : t) = | Some pages -> Odoc_utils.List.filter_map filter @@ all_roots ?root pages let all_units ~library ({ libs; _ } : t) = - let filter (root : Odoc_model.Root.t) = + let filter (root : _ * Odoc_model.Root.t) = match root with - | { - file = Compilation_unit _; - id = { iv = #Odoc_model.Paths.Identifier.RootModule.t_pv; _ } as id; - _; - } -> - Some id + | ( file, + { + file = Compilation_unit _; + id = { iv = #Odoc_model.Paths.Identifier.RootModule.t_pv; _ } as id; + _; + } ) -> + let file () = + match Odoc_file.load file with + | Ok { content = Odoc_file.Unit_content u; _ } -> Some u + | Ok { content = _; _ } -> assert false + | Error _ -> (* TODO: Report as warning or propagate error *) None + in + Some (file, id) | _ -> None in match libs with diff --git a/src/odoc/resolver.mli b/src/odoc/resolver.mli index e48319261e..7e48a7e7c8 100644 --- a/src/odoc/resolver.mli +++ b/src/odoc/resolver.mli @@ -54,7 +54,10 @@ val all_pages : (Paths.Identifier.Page.t * Comment.link_content option * Frontmatter.t) list val all_units : - library:string -> t -> Odoc_model.Paths.Identifier.RootModule.t list + library:string -> + t -> + ((unit -> Lang.Compilation_unit.t option) * Paths.Identifier.RootModule.t) + list (** Helpers for creating xref2 env. *) diff --git a/src/search/html.ml b/src/search/html.ml index da016bd55d..7e9619e43f 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -17,7 +17,7 @@ let url { Entry.id; kind; doc = _ } = Values, types, ... are not sensitive to [stop_before], allowing us to shorten the match. *) - match kind with Doc _ -> false | _ -> true + match kind with Doc -> false | _ -> true in let url = Odoc_document.Url.from_identifier ~stop_before id in let config = @@ -156,15 +156,15 @@ let string_of_kind = | Field _ -> kind_field | ExtensionConstructor _ -> kind_extension_constructor | TypeDecl _ -> kind_typedecl - | Module -> kind_module + | 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_doc + | ModuleType _ -> kind_module_type + | Doc -> kind_doc let value_rhs (t : Entry.value_entry) = " : " ^ Text.of_type t.type_ @@ -181,8 +181,8 @@ let rhs_of_kind (entry : Entry.kind) = | Constructor t | ExtensionConstructor t | Exception t -> Some (constructor_rhs t) | Field f -> Some (field_rhs f) - | Module | Class_type _ | Method _ | Class _ | TypeExtension _ | ModuleType - | Doc _ -> + | Module _ | Class_type _ | Method _ | Class _ | TypeExtension _ + | ModuleType _ | Doc -> None let names_of_id id = diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index 102bbbd144..6b8b2f3c53 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -123,14 +123,10 @@ let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = ("manifest", manifest); ("constraints", constraints); ] - | Module -> return "Module" [] + | Module _ -> return "Module" [] | Value { value = _; type_ } -> return "Value" [ ("type", `String (Text.of_type type_)) ] - | Doc Paragraph -> return "Doc" [ ("subkind", `String "Paragraph") ] - | Doc Heading -> return "Doc" [ ("subkind", `String "Heading") ] - | Doc CodeBlock -> return "Doc" [ ("subkind", `String "CodeBlock") ] - | Doc MathBlock -> return "Doc" [ ("subkind", `String "MathBlock") ] - | Doc Verbatim -> return "Doc" [ ("subkind", `String "Verbatim") ] + | Doc -> return "Doc" [] | Exception { args; res } -> let args = json_of_args args in let res = `String (Text.of_type res) in @@ -153,7 +149,7 @@ let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = let args = json_of_args args in let res = `String (Text.of_type res) in return "ExtensionConstructor" [ ("args", args); ("res", res) ] - | ModuleType -> return "ModuleType" [] + | ModuleType _ -> return "ModuleType" [] | Constructor { args; res } -> let args = json_of_args args in let res = `String (Text.of_type res) in @@ -184,18 +180,15 @@ let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = ([ ("id", j_id); ("doc", doc); ("kind", kind); ("display", display) ] @ occurrences) -let output_json ppf first entries = +let output_json ppf first (entry, html, occurrences) = let output_json json = let str = Odoc_html.Json.to_string json in Format.fprintf ppf "%s\n" str in - List.fold_left - (fun first (entry, html, occurrences) -> - let json = of_entry entry html occurrences in - if not first then Format.fprintf ppf ","; - output_json json; - false) - first entries + let json = of_entry entry html occurrences in + if not first then Format.fprintf ppf ","; + output_json json; + false let unit ?occurrences ppf u = let get_occ id = @@ -206,34 +199,28 @@ let unit ?occurrences ppf u = | Some x -> Some x | None -> Some { direct = 0; indirect = 0 }) in - let f first i = - let entries = Entry.entries_of_item i in - let entries = - List.map - (fun entry -> - let occ = get_occ entry.Entry.id in - (entry, Html.of_entry entry, occ)) - entries + let f first entry = + let entry = + let occ = get_occ entry.Entry.id in + (entry, Html.of_entry entry, occ) in - let first = output_json ppf first entries in + let first = output_json ppf first entry in first in - let _first = Fold.unit ~f true u in + let skel = Odoc_index.Skeleton.from_unit u in + let _first = Odoc_utils.Tree.fold_left ~f true skel in () 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 (fun entry -> (entry, Html.of_entry entry, None)) entries - in - output_json ppf first entries + let f first entry = + let entry = (entry, Html.of_entry entry, None) in + output_json ppf first entry in - let _first = Fold.page ~f true page in + let skel = Odoc_index.Skeleton.from_page page in + let _first = Odoc_utils.Tree.fold_left ~f true skel in () -let index ?occurrences ppf - (index : Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t) = +let index ?occurrences ppf (index : Skeleton.t list) = let get_occ id = match occurrences with | None -> None @@ -243,11 +230,9 @@ let index ?occurrences ppf | None -> Some { direct = 0; indirect = 0 }) in let _first = - Odoc_model.Paths.Identifier.Hashtbl.Any.fold - (fun _id entry first -> + Odoc_utils.Forest.fold_left true index ~f:(fun first entry -> let occ = get_occ entry.Entry.id in let entry = (entry, Html.of_entry entry, occ) in - output_json ppf first [ entry ]) - index true + output_json ppf first entry) in () diff --git a/src/search/json_index/json_search.mli b/src/search/json_index/json_search.mli index 95d8014c29..2a5184ada5 100644 --- a/src/search/json_index/json_search.mli +++ b/src/search/json_index/json_search.mli @@ -9,5 +9,5 @@ val page : Format.formatter -> Odoc_model.Lang.Page.t -> unit val index : ?occurrences:Odoc_occurrences.Table.t -> Format.formatter -> - Odoc_index.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> + Odoc_index.Skeleton.t list -> unit diff --git a/test/pages/toc_order.t/run.t b/test/pages/toc_order.t/run.t index ab3ec23577..ad7f595bf1 100644 --- a/test/pages/toc_order.t/run.t +++ b/test/pages/toc_order.t/run.t @@ -58,8 +58,9 @@ Typo is in the children field of index, but does not exist. It is omitted to, but this should be a warning! $ cat _html/pkg/index.html | grep odoc-global-toc -A 11 -