Add the ability to remap identifiers during HTML generation

This is to allow the publishing of 'partial docsets' - the idea being
that the driver proceeds as usual up until HTML generation, and at that
point only generates HTML pages for the packages you wish to publish on
your site, and remap links to other packages to ocaml.org or other site.

Author: jonludlam

src/html/config.ml

@@ -4,6 +4,7 @@ type t = {
   theme_uri : Types.uri option;
   support_uri : Types.uri option;
   search_uris : Types.file_uri list;
+  remap : (string * string) list;
   semantic_uris : bool;
   search_result : bool;
       (* Used to not render links, for summary in search results *)
@@ -14,7 +15,7 @@ type t = {
 }
 
 let v ?(search_result = false) ?theme_uri ?support_uri ?(search_uris = [])
-    ~semantic_uris ~indent ~flat ~open_details ~as_json () =
+    ~semantic_uris ~indent ~flat ~open_details ~as_json ~remap () =
   {
     semantic_uris;
     indent;
@@ -25,6 +26,7 @@ let v ?(search_result = false) ?theme_uri ?support_uri ?(search_uris = [])
     search_uris;
     as_json;
     search_result;
+    remap;
   }
 
 let theme_uri config : Types.uri =
@@ -46,3 +48,5 @@ let open_details config = config.open_details
 let as_json config = config.as_json
 
 let search_result config = config.search_result
+
+let remap config = config.remap

src/html/config.mli

@@ -12,6 +12,7 @@ val v :
   flat:bool ->
   open_details:bool ->
   as_json:bool ->
+  remap:(string * string) list ->
   unit ->
   t
 (** [search_result] indicates whether this is a summary for a search result. In
@@ -34,3 +35,5 @@ val open_details : t -> bool
 val as_json : t -> bool
 
 val search_result : t -> bool
+
+val remap : t -> (string * string) list

src/html/generator.ml

@@ -542,7 +542,7 @@ let render ~config ~sidebar = function
   | Source_page src -> [ Page.source_page ~config src ]
 
 let filepath ~config url =
-  Link.Path.as_filename ~is_flat:(Config.flat config) url
+  Link.Path.as_filename ~config url
 
 let doc ~config ~xref_base_uri b =
   let resolve = Link.Base xref_base_uri in

src/html/html_fragment_json.ml

@@ -32,7 +32,7 @@ let json_of_toc (toc : Types.toc list) : Utils.Json.json =
 
 let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex
     ~source_anchor content children =
-  let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
+  let filename = Link.Path.as_filename ~config url in
   let filename = Fpath.add_ext ".json" filename in
   let json_to_string json = Utils.Json.to_string json in
   let source_anchor =
@@ -65,7 +65,7 @@ let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex
   { Odoc_document.Renderer.filename; content; children }
 
 let make_src ~config ~url ~breadcrumbs content =
-  let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
+  let filename = Link.Path.as_filename ~config url in
   let filename = Fpath.add_ext ".json" filename in
   let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in
   let json_to_string json = Utils.Json.to_string json in

src/html/html_page.ml

@@ -244,7 +244,7 @@ let search_urls = %s;
 
 let make ~config ~url ~header ~breadcrumbs ~sidebar ~toc ~uses_katex content
     children =
-  let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
+  let filename = Link.Path.as_filename ~config url in
   let content =
     page_creator ~config ~url ~uses_katex ~global_toc:sidebar header breadcrumbs
       toc content
@@ -285,7 +285,7 @@ let src_page_creator ~breadcrumbs ~config ~url ~header name content =
   content
 
 let make_src ~config ~url ~breadcrumbs ~header title content =
-  let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
+  let filename = Link.Path.as_filename ~config url in
   let content =
     src_page_creator ~breadcrumbs ~config ~url ~header title content
   in

src/html/link.ml

@@ -1,5 +1,7 @@
 module Url = Odoc_document.Url
 
+type link = Relative of string list * string | Absolute of string
+
 (* Translation from Url.Path *)
 module Path = struct
   let for_printing url = List.map snd @@ Url.Path.to_list url
@@ -11,10 +13,23 @@ module Path = struct
 
   let is_leaf_page url = url.Url.Path.kind = `LeafPage
 
-  let get_dir_and_file is_flat url =
+  let remap config f =
+    let l = String.concat "/" f in
+    match
+      List.find_opt
+        (fun (prefix, _replacement) -> Astring.String.is_prefix ~affix:prefix l)
+        (Config.remap config)
+    with
+    | None -> None
+    | Some (prefix, replacement) ->
+        let len = String.length prefix in
+        let l = String.sub l len (String.length l - len) in
+        Some (replacement ^ l)
+
+  let get_dir_and_file ~config url =
     let l = Url.Path.to_list url in
     let is_dir =
-      if is_flat then function `Page -> `Always | _ -> `Never
+      if Config.flat config then function `Page -> `Always | _ -> `Never
       else function `LeafPage | `File | `SourcePage -> `Never | _ -> `Always
     in
     let dir, file = Url.Path.split ~is_dir l in
@@ -26,19 +41,20 @@ module Path = struct
       | [ (`File, name) ] -> name
       | [ (`SourcePage, name) ] -> name ^ ".html"
       | xs ->
-          assert is_flat;
+          assert (Config.flat config);
           String.concat "-" (List.map segment_to_string xs) ^ ".html"
     in
     (dir, file)
 
-  let for_linking ~is_flat url =
-    let dir, file = get_dir_and_file is_flat url in
-    dir @ [ file ]
+  let for_linking ~config url =
+    let dir, file = get_dir_and_file ~config url in
+    match remap config dir with
+    | None -> Relative (dir, file)
+    | Some x -> Absolute (x ^ "/" ^ file)
 
-  let as_filename ~is_flat (url : Url.Path.t) =
-    let url_segs = for_linking ~is_flat url in
-    let filename = Fpath.(v @@ String.concat Fpath.dir_sep @@ url_segs) in
-    filename
+  let as_filename ~config (url : Url.Path.t) =
+    let dir, file = get_dir_and_file ~config url in
+    Fpath.(v @@ String.concat Fpath.dir_sep (dir @ [ file ]))
 end
 
 type resolve = Current of Url.Path.t | Base of string
@@ -50,46 +66,55 @@ let rec drop_shared_prefix l1 l2 =
 
 let href ~config ~resolve t =
   let { Url.Anchor.page; anchor; _ } = t in
+  let add_anchor y = match anchor with "" -> y | anchor -> y ^ "#" ^ anchor in
+  let target_loc = Path.for_linking ~config page in
 
-  let target_loc = Path.for_linking ~is_flat:(Config.flat config) page in
-
-  (* If xref_base_uri is defined, do not perform relative URI resolution. *)
-  match resolve with
-  | Base xref_base_uri -> (
-      let page = xref_base_uri ^ String.concat "/" target_loc in
-      match anchor with "" -> page | anchor -> page ^ "#" ^ anchor)
-  | Current path -> (
-      let current_loc = Path.for_linking ~is_flat:(Config.flat config) path in
+  match target_loc with
+  | Absolute y -> add_anchor y
+  | Relative (dir, file) -> (
+      let target_loc = dir @ [ file ] in
+      (* If xref_base_uri is defined, do not perform relative URI resolution. *)
+      match resolve with
+      | Base xref_base_uri ->
+          let page = xref_base_uri ^ String.concat "/" target_loc in
+          add_anchor page
+      | Current path -> (
+          let current_loc =
+            let dir, file = Path.get_dir_and_file ~config path in
+            dir @ [ file ]
+          in
 
-      let current_from_common_ancestor, target_from_common_ancestor =
-        drop_shared_prefix current_loc target_loc
-      in
+          let current_from_common_ancestor, target_from_common_ancestor =
+            drop_shared_prefix current_loc target_loc
+          in
 
-      let relative_target =
-        match current_from_common_ancestor with
-        | [] ->
-            (* We're already on the right page *)
-            (* If we're already on the right page, the target from our common
-                ancestor can't be anything other than the empty list *)
-            assert (target_from_common_ancestor = []);
-            []
-        | [ _ ] ->
-            (* We're already in the right dir *)
-            target_from_common_ancestor
-        | l ->
-            (* We need to go up some dirs *)
-            List.map (fun _ -> "..") (List.tl l) @ target_from_common_ancestor
-      in
-      let remove_index_html l =
-        match List.rev l with
-        | "index.html" :: rest -> List.rev ("" :: rest)
-        | _ -> l
-      in
-      let relative_target =
-        if Config.semantic_uris config then remove_index_html relative_target
-        else relative_target
-      in
-      match (relative_target, anchor) with
-      | [], "" -> "#"
-      | page, "" -> String.concat "/" page
-      | page, anchor -> String.concat "/" page ^ "#" ^ anchor)
+          let relative_target =
+            match current_from_common_ancestor with
+            | [] ->
+                (* We're already on the right page *)
+                (* If we're already on the right page, the target from our common
+                    ancestor can't be anything other than the empty list *)
+                assert (target_from_common_ancestor = []);
+                []
+            | [ _ ] ->
+                (* We're already in the right dir *)
+                target_from_common_ancestor
+            | l ->
+                (* We need to go up some dirs *)
+                List.map (fun _ -> "..") (List.tl l)
+                @ target_from_common_ancestor
+          in
+          let remove_index_html l =
+            match List.rev l with
+            | "index.html" :: rest -> List.rev ("" :: rest)
+            | _ -> l
+          in
+          let relative_target =
+            if Config.semantic_uris config then
+              remove_index_html relative_target
+            else relative_target
+          in
+          match (relative_target, anchor) with
+          | [], "" -> "#"
+          | page, "" -> String.concat "/" page
+          | page, anchor -> String.concat "/" page ^ "#" ^ anchor))

src/html/link.mli

@@ -11,7 +11,5 @@ module Path : sig
 
   val for_printing : Url.Path.t -> string list
 
-  val for_linking : is_flat:bool -> Url.Path.t -> string list
-
-  val as_filename : is_flat:bool -> Url.Path.t -> Fpath.t
+  val as_filename : config:Config.t -> Url.Path.t -> Fpath.t
 end

src/odoc/bin/main.ml

@@ -1176,19 +1176,31 @@ module Odoc_html_args = struct
     in
     Arg.(value & flag & info ~doc [ "as-json" ])
 
+  let remap =
+    let convert_remap =
+      let parse inp =
+        match Astring.String.cut ~sep:":" inp with
+        | Some (orig, mapped) -> Ok (orig, mapped)
+        | _ -> Error (`Msg "Map must be of the form '<orig>:https://...'")
+      and print fmt (orig, mapped) = Format.fprintf fmt "%s:%s" orig mapped in
+      Arg.conv (parse, print)
+    in
+    let doc = "Remap an identifier to an external URL." in
+    Arg.(value & opt_all convert_remap [] & info [ "R" ] ~doc)
+
   let extra_args =
     let config semantic_uris closed_details indent theme_uri support_uri
-        search_uris flat as_json =
+        search_uris flat as_json remap =
       let open_details = not closed_details in
       let html_config =
         Odoc_html.Config.v ~theme_uri ~support_uri ~search_uris ~semantic_uris
-          ~indent ~flat ~open_details ~as_json ()
+          ~indent ~flat ~open_details ~as_json ~remap ()
       in
       { Html_page.html_config }
     in
     Term.(
       const config $ semantic_uris $ closed_details $ indent $ theme_uri
-      $ support_uri $ search_uri $ flat $ as_json)
+      $ support_uri $ search_uri $ flat $ as_json $ remap)
 end
 
 module Odoc_html = Make_renderer (Odoc_html_args)

src/odoc/html_fragment.ml

@@ -37,7 +37,7 @@ let from_mld ~xref_base_uri ~resolver ~output ~warnings_options input =
     let page = Odoc_document.Comment.to_ir resolved.content in
     let config =
       Odoc_html.Config.v ~semantic_uris:false ~indent:false ~flat:false
-        ~open_details:false ~as_json:false ()
+        ~open_details:false ~as_json:false ~remap:[] ()
     in
     let html = Odoc_html.Generator.doc ~config ~xref_base_uri page in
     let oc = open_out (Fs.File.to_string output) in

src/search/html.ml

@@ -22,7 +22,8 @@ let url { Entry.id; kind; doc = _ } =
   | Ok url ->
       let config =
         Odoc_html.Config.v ~search_result:true ~semantic_uris:false
-          ~indent:false ~flat:false ~open_details:false ~as_json:false ()
+          ~indent:false ~flat:false ~open_details:false ~as_json:false ~remap:[]
+          ()
       in
       let url = Odoc_html.Link.href ~config ~resolve:(Base "") url in
       Result.Ok url
@@ -201,7 +202,7 @@ let names_of_id id =
 let of_doc doc =
   let config =
     Odoc_html.Config.v ~search_result:true ~semantic_uris:false ~indent:false
-      ~flat:false ~open_details:false ~as_json:false ()
+      ~flat:false ~open_details:false ~as_json:false ~remap:[] ()
   in
   Tyxml.Html.div ~a:[]
   @@ Odoc_html.Generator.doc ~config ~xref_base_uri:""