Add the ability to remap identifiers during HTML generation

CHANGES.md

@@ -28,6 +28,7 @@
 - Allow referencing assets (@panglesd, #1171)
 - Added a `--asset-path` arg to `html-generate` (@panglesd, #1185)
 - Add a frontmatter syntax for mld pages (@panglesd, #1187)
+- Add a 'remap' option to HTML generation for partial docsets (@jonludlam, #1189)
 
 ### Changed
 

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

@@ -541,8 +541,7 @@ let render ~config ~sidebar = function
   | Document.Page page -> [ Page.page ~config ~sidebar page ]
   | Source_page src -> [ Page.source_page ~config src ]
 
-let filepath ~config url =
-  Link.Path.as_filename ~is_flat:(Config.flat config) url
+let filepath ~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,24 @@ 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
+    try
+      let prefix, replacement =
+        List.find
+          (fun (prefix, _replacement) ->
+            Astring.String.is_prefix ~affix:prefix l)
+          (Config.remap config)
+      in
+      let len = String.length prefix in
+      let l = String.sub l len (String.length l - len) in
+      Some (replacement ^ l)
+    with Not_found -> None
+
+  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 +42,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 +67,54 @@ 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, _ -> add_anchor @@ String.concat "/" page))

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) -> Result.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:""

test/integration/remap.t/otherlib.mli

@@ -0,0 +1,2 @@
+type t = Foo | Bar
+

test/integration/remap.t/run.t

@@ -0,0 +1,20 @@
+  $ ocamlc -c -bin-annot otherlib.mli
+  $ ocamlc -c -bin-annot test.mli
+  $ odoc compile --parent-id prefix/otherpkg/doc --output-dir _odoc otherlib.cmti
+  $ odoc compile --parent-id prefix/mypkg/doc --output-dir _odoc test.cmti
+  $ odoc link _odoc/prefix/otherpkg/doc/otherlib.odoc
+  $ odoc link -I _odoc/prefix/otherpkg/doc _odoc/prefix/mypkg/doc/test.odoc
+
+We should be able to remap the links to one of the packages:
+
+  $ odoc html-generate -o _html --indent _odoc/prefix/mypkg/doc/test.odocl
+  $ odoc html-generate -o _html2 --indent _odoc/prefix/mypkg/doc/test.odocl -R prefix/otherpkg/:https://mysite.org/p/otherpkg/1.2.3/
+
+  $ grep Otherlib/index.html _html/prefix/mypkg/doc/Test/index.html _html2/prefix/mypkg/doc/Test/index.html
+  _html/prefix/mypkg/doc/Test/index.html:       <a href="../../../otherpkg/doc/Otherlib/index.html#type-t">Otherlib.t
+  _html2/prefix/mypkg/doc/Test/index.html:        href="https://mysite.org/p/otherpkg/1.2.3/doc/Otherlib/index.html#type-t"
+
+This shouldn't stop us from outputting the remapped package though, and the following should complete without error
+
+  $ odoc html-generate -o _html3 _odoc/prefix/otherpkg/doc/otherlib.odocl -R prefix/otherpkg/:https://mysite.org/p/otherpkg/1.2.3/
+

test/integration/remap.t/test.mli

@@ -0,0 +1,2 @@
+type t = Otherlib.t
+