Create a separate module for intermediate index

src/index/in_progress.ml

@@ -0,0 +1,92 @@
+open Odoc_model
+
+module Id = Odoc_model.Paths.Identifier
+module PageName = Odoc_model.Names.PageName
+
+module CPH = Id.Hashtbl.ContainerPage
+module LPH = Id.Hashtbl.LeafPage
+module RMH = Id.Hashtbl.RootModule
+
+type page = Id.Page.t
+type container_page = Id.ContainerPage.t
+
+open Astring
+
+type payload = Lang.Page.t
+
+type dir_content = {
+  leafs : payload LPH.t;
+  dirs : in_progress CPH.t;
+  modules : Skeleton.t RMH.t;
+}
+and in_progress = container_page option * dir_content
+
+let empty_t dir_id =
+  ( dir_id,
+    { leafs = LPH.create 10; dirs = CPH.create 10; modules = RMH.create 10 } )
+
+let get_parent id : container_page option =
+  let id :> page = id in
+  match id.iv with
+  | `Page (Some parent, _) -> Some parent
+  | `LeafPage (Some parent, _) -> Some parent
+  | `Page (None, _) | `LeafPage (None, _) -> None
+
+let find_leaf ((_, dir_content) : in_progress) leaf_page =
+  try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None
+
+let leafs (_, dir_content) =
+  LPH.fold
+    (fun id page acc ->
+      if String.equal "index" (Id.name id) then acc else (id, page) :: acc)
+    dir_content.leafs []
+
+let dirs (_, dir_content) =
+  CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs []
+
+let modules (_, dir_content) =
+  RMH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.modules []
+
+let rec get_or_create (dir : in_progress) (id : container_page) : in_progress =
+  let _, { dirs = parent_dirs; _ } =
+    match get_parent id with
+    | Some parent -> get_or_create dir parent
+    | None -> dir
+  in
+  let current_item =
+    try Some (CPH.find parent_dirs id) with Not_found -> None
+  in
+  match current_item with
+  | Some item -> item
+  | None ->
+      let new_ = empty_t (Some id) in
+      CPH.add parent_dirs id new_;
+      new_
+
+let add_page (dir : in_progress) page =
+  match page.Lang.Page.name with
+  | { iv = #Id.LeafPage.t_pv; _ } as id ->
+      let _, dir_content =
+        match get_parent id with
+        | Some parent -> get_or_create dir parent
+        | None -> dir
+      in
+      LPH.replace dir_content.leafs id page
+  | _ -> ()
+
+let add_module (dir : in_progress) m =
+  let _, dir_content =
+    match m.Lang.Compilation_unit.id.iv with
+    | `Root (Some parent, _) -> get_or_create dir parent
+    | `Root (None, _) -> dir
+  in
+  let skel = Skeleton.from_unit m in
+  RMH.replace dir_content.modules m.id skel
+
+let index ((parent_id, _) as dir) =
+  let index_id = Id.Mk.leaf_page (parent_id, PageName.make_std "index") in
+  match find_leaf dir index_id with
+  | Some payload -> Some (index_id, payload)
+  | None -> None
+
+let root_dir (parent_id, _) = parent_id

src/index/in_progress.mli

@@ -0,0 +1,37 @@
+(** Intermediate representation for pages hierarchies to be able to add pages before  *)
+
+module Id = Odoc_model.Paths.Identifier
+open Odoc_model
+
+type in_progress
+(** A directory *)
+
+(** {1 Initial value} *)
+
+val empty_t : Id.ContainerPage.t option -> in_progress
+(** Start a hierarchy for a parent ID ([None] is for the absolute root) *)
+
+(** {1 Add to the initial value} *)
+
+val add_page : in_progress -> Lang.Page.t -> unit
+(** Add a leaf pages in the given dir *)
+
+val add_module : in_progress -> Lang.Compilation_unit.t -> unit
+(** Add a mpodule in the given dir *)
+
+(** {1 Getters} *)
+
+val root_dir : in_progress -> Id.ContainerPage.t option
+(** [root dir] is the parent ID represented by [dir] *)
+
+val leafs : in_progress -> (Id.LeafPage.t * Lang.Page.t) list
+(** [leafs dir] returns the leaf pages in [dir] *)
+
+val dirs : in_progress -> (Id.ContainerPage.t * in_progress) list
+(** [dirs dir] returns the intermediate directories in [dir] *)
+
+val modules : in_progress -> (Id.RootModule.t * Skeleton.t) list
+(** [modules dir] returns the modules in [dir] *)
+
+val index : in_progress -> (Id.LeafPage.t * Lang.Page.t) option
+(** [index dir] returns the potential [index] leaf page in [dir] *)

src/index/skeleton_of.ml

@@ -5,110 +5,24 @@ open Odoc_model
 module Id = Odoc_model.Paths.Identifier
 module PageName = Odoc_model.Names.PageName
 
-module CPH = Id.Hashtbl.ContainerPage
-module LPH = Id.Hashtbl.LeafPage
-module RMH = Id.Hashtbl.RootModule
-
-type page = Id.Page.t
-type container_page = Id.ContainerPage.t
-
-open Astring
-
-type payload = Lang.Page.t
-
-type dir_content = {
-  leafs : payload LPH.t;
-  dirs : in_progress CPH.t;
-  modules : Skeleton.t RMH.t;
-}
-and in_progress = container_page option * dir_content
-
-let empty_t dir_id =
-  ( dir_id,
-    { leafs = LPH.create 10; dirs = CPH.create 10; modules = RMH.create 10 } )
-
-let get_parent id : container_page option =
-  let id :> page = id in
-  match id.iv with
-  | `Page (Some parent, _) -> Some parent
-  | `LeafPage (Some parent, _) -> Some parent
-  | `Page (None, _) | `LeafPage (None, _) -> None
-
-let find_leaf ((_, dir_content) : in_progress) leaf_page =
-  try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None
-
-let leafs (_, dir_content) =
-  LPH.fold
-    (fun id page acc ->
-      if String.equal "index" (Id.name id) then acc else (id, page) :: acc)
-    dir_content.leafs []
-
-let dirs (_, dir_content) =
-  CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs []
-
-let modules (_, dir_content) =
-  RMH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.modules []
-
-let rec get_or_create (dir : in_progress) (id : container_page) : in_progress =
-  let _, { dirs = parent_dirs; _ } =
-    match get_parent id with
-    | Some parent -> get_or_create dir parent
-    | None -> dir
-  in
-  let current_item =
-    try Some (CPH.find parent_dirs id) with Not_found -> None
-  in
-  match current_item with
-  | Some item -> item
-  | None ->
-      let new_ = empty_t (Some id) in
-      CPH.add parent_dirs id new_;
-      new_
-
-let add_page (dir : in_progress) page =
-  match page.Lang.Page.name with
-  | { iv = #Id.LeafPage.t_pv; _ } as id ->
-      let _, dir_content =
-        match get_parent id with
-        | Some parent -> get_or_create dir parent
-        | None -> dir
-      in
-      LPH.replace dir_content.leafs id page
-  | _ -> ()
-
-let add_module (dir : in_progress) m =
-  let _, dir_content =
-    match m.Lang.Compilation_unit.id.iv with
-    | `Root (Some parent, _) -> get_or_create dir parent
-    | `Root (None, _) -> dir
-  in
-  let skel = Skeleton.from_unit m in
-  RMH.replace dir_content.modules m.id skel
-
-let dir_index ((parent_id, _) as dir) =
-  let index_id = Id.Mk.leaf_page (parent_id, PageName.make_std "index") in
-  match find_leaf dir index_id with
-  | Some payload -> Some (index_id, payload)
-  | None -> None
-
 type t = Entry.t Tree.t
 
-let rec t_of_in_progress (dir : in_progress) : t =
+let rec t_of_in_progress (dir : In_progress.in_progress) : t =
   let entry_of_page page =
     let kind = Entry.Page page.Lang.Page.frontmatter in
     let doc = page.content in
     let id = page.name in
     Entry.entry ~kind ~doc ~id
   in
   let children_order, index =
-    match dir_index dir with
+    match In_progress.index dir with
     | Some (_, page) ->
         let children_order = page.frontmatter.children_order in
         let entry = entry_of_page page in
         (children_order, entry)
     | None ->
         let entry =
-          match fst dir with
+          match In_progress.root_dir dir with
           | Some id ->
               let kind = Entry.Dir in
               let doc = [] in
@@ -137,14 +51,14 @@ let rec t_of_in_progress (dir : in_progress) : t =
   let ordered, unordered =
     let contents =
       let leafs =
-        leafs dir
+        In_progress.leafs dir
         |> List.map (fun (_, page) ->
                let id :> Id.Page.t = page.Lang.Page.name in
                let entry = entry_of_page page in
                (id, Tree.leaf entry))
       in
       let dirs =
-        dirs dir
+        In_progress.dirs dir
         |> List.map (fun (id, payload) ->
                let id :> Id.Page.t = id in
                (id, t_of_in_progress payload))
@@ -215,17 +129,17 @@ let rec t_of_in_progress (dir : in_progress) : t =
         String.compare (Paths.Identifier.name x) (Paths.Identifier.name y))
       unordered
   in
-  let modules = modules dir |> List.map snd in
+  let modules = In_progress.modules dir |> List.map snd in
   let contents = ordered @ unordered |> List.map snd in
-  { Tree.node = index (* , modules *); children = contents @ modules }
+  { Tree.node = index; children = contents @ modules }
 
 let rec remove_common_root (v : t) =
   match v with
   | { Tree.children = [ v ]; node = { kind = Dir; _ } } -> remove_common_root v
   | _ -> v
 
 let lang ~pages ~modules =
-  let dir = empty_t None in
-  List.iter (add_page dir) pages;
-  List.iter (add_module dir) modules;
+  let dir = In_progress.empty_t None in
+  List.iter (In_progress.add_page dir) pages;
+  List.iter (In_progress.add_module dir) modules;
   t_of_in_progress dir |> remove_common_root