Copy images when building documentation

We now parse the Markdown for images (including in raw HTML blocks).
When found, we attempt to resolve them relative to the current file, and
copy them into the output directory.

dune-project

@@ -46,7 +46,9 @@
     js_of_ocaml
     logs
     lrgrep
+    markup
     menhir
     menhirLib
     re
+    uri
     yojson))

illuaminate.opam

@@ -31,9 +31,11 @@ depends: [
   "js_of_ocaml"
   "logs"
   "lrgrep"
+  "markup"
   "menhir"
   "menhirLib"
   "re"
+  "uri"
   "yojson"
 ]
 build: [

src/bin/cli/illuaminate_cli.ml

@@ -100,43 +100,49 @@ let doc_gen path =
   let module E = IlluaminateDocEmit in
   let path = CCOption.get_lazy (fun () -> Sys.getcwd () |> Fpath.v) path in
   let root = if Sys.is_directory (Fpath.to_string path) then path else Fpath.parent path in
-  let to_abs path = Fpath.(to_string (root // path)) in
-  let open struct
-    let emit_doc node out =
-      let fmt = Format.formatter_of_out_channel out in
-      Html.Default.emit_doc fmt node; Format.pp_print_flush fmt ()
-
-    let resolve_logo ~destination logo =
-      if Fpath.is_rooted ~root:destination logo then
-        Fpath.relativize ~root:destination logo |> Option.get |> Fpath.to_string
-      else
-        let our_logo = Fpath.(base logo |> to_string) in
-        CCIO.(
-          with_in (to_abs logo) @@ fun i ->
-          with_out Fpath.(destination / our_logo |> to_string) @@ fun o -> copy_into i o);
-        our_logo
-
-    let parse_index ~options path =
-      E.Html.load_file ~options path
-      |> Result.fold ~ok:Fun.id ~error:(fun e -> Printf.eprintf "%s\n%!" e; exit 1)
-
-    let gen_appended ~destination ~name ~contents extra =
-      let output = Fpath.(destination / name |> to_string) in
-      ( CCIO.with_out output @@ fun out ->
-        output_string out contents;
-        Option.iter
-          (fun extra -> CCIO.with_in (to_abs extra) @@ fun i -> CCIO.copy_into i out)
-          extra );
-      (* Append an 8 byte cachebuster. There's no reason to only make it 8 bytes, but it doesn't
-         need to be a full hash either. *)
-      let hash = Digest.file output |> Digest.to_hex |> CCString.take 8 in
-      Printf.sprintf "%s?v=%s" name hash
-  end in
+  let to_abs' path = Fpath.(root // path |> normalize) in
+  let to_abs path = Fpath.to_string (to_abs' path) in
+
+  (* Write a HTML doc to a file. *)
+  let emit_doc node out =
+    let fmt = Format.formatter_of_out_channel out in
+    Html.Default.emit_doc fmt node; Format.pp_print_flush fmt ()
+  in
+
+  (* Resolve the path to the logo, copying it into the output directory if needed. *)
+  let resolve_logo ~data ~destination logo =
+    if Fpath.is_rooted ~root:destination logo then
+      Fpath.relativize ~root:destination logo |> Option.get |> Fpath.to_string
+    else
+      match IlluaminateData.get data E.Html.Assets.find_asset (to_abs' logo) with
+      | None ->
+          Log.err (fun f -> f "Cannot find logo %a" Fpath.pp logo);
+          exit 1
+      | Some logo -> logo
+  in
+
+  (* Parse the index file. *)
+  let parse_index ~options path =
+    match E.Html.load_file ~options path with
+    | Ok res -> res
+    | Error e ->
+        Log.err (fun f -> f "Cannot parse index file %a: %s" Fpath.pp path e);
+        exit 1
+  in
+
+  (* Generate an asset file from some [contents], appending the contents of [extra] if needed. *)
+  let gen_appended ~destination ~name ~contents extra =
+    let output = Fpath.(destination / name) in
+    ( Out_channel.with_open_bin (Fpath.to_string output) @@ fun out ->
+      output_string out contents;
+      Option.iter
+        (fun extra -> In_channel.with_open_bin (to_abs extra) @@ fun i -> CCIO.copy_into i out)
+        extra );
+    E.Html.Assets.hashed_url output name
+  in
   let loaded, errs = Loader.load_from path in
   (loaded
-  |> Option.iter @@ fun (config, _, builder) ->
-     let data = IlluaminateData.Builder.build builder in
-     let pages = IlluaminateData.get data Doc.Extract.public_pages () in
+  |> Option.iter @@ fun (config, _, configure_builder) ->
      let { Config.DocOptions.site_properties =
              { site_title; site_image; site_url; embed_head; embed_js; embed_css; source_link };
            index;
@@ -145,9 +151,15 @@ let doc_gen path =
          } =
        Config.get_doc_options config
      in
+     let data =
+       IlluaminateData.Builder.build (fun buider ->
+           configure_builder buider;
+           E.Html.Assets.add_find_asset destination buider)
+     in
+     let pages = IlluaminateData.get data Doc.Extract.public_pages () in
 
      mkdirs destination;
-     let site_image = Option.map (resolve_logo ~destination) site_image in
+     let site_image = Option.map (resolve_logo ~data ~destination) site_image in
      let site_css =
        gen_appended ~destination ~name:"main.css" ~contents:E.Html.embedded_css embed_css
      in

src/data/core.ml

@@ -269,7 +269,9 @@ let build_result (type k v) store (rule : (k, v) Key.t) (key : k) ~has_change ~p
       trace
     }
   in
-  let log kind = Log.info (fun f -> f "Finished %a in %.2f (%s)" rule.pp key delta kind) in
+  let log kind =
+    Log.info (fun f -> f "Finished %s[%a] in %.2f (%s)" rule.name rule.pp key delta kind)
+  in
   match previous with
   | Some ({ changed_at; _ } as old) -> (
     match new_result.changed with

src/doc_emit/dune

@@ -5,15 +5,17 @@
  (libraries
   cmarkit
   containers
+  fpath
   illuaminate
   illuaminate.core
   illuaminate.data
   illuaminate.html
   illuaminate.parser
   illuaminate.semantics
-  fpath
-  yojson
-  unix)
+  markup
+  unix
+  uri
+  yojson)
  (preprocess
   (pps jsx))
  (instrumentation

src/doc_emit/html_assets.ml

@@ -0,0 +1,35 @@
+(** Compute the hash of a file. *)
+let hash_file path = Digest.file (Fpath.to_string path) |> Digest.to_hex |> CCString.take 8
+
+(** [hashed_url path url]: Append a cachbuster (derived from the hash of [path]) to [url]. *)
+let hashed_url path url = Printf.sprintf "%s?v=%s" url (hash_file path)
+
+(** Find an asset located at the specified path, and copy it into the site's target directory,
+    returning the new file name. *)
+let find_asset : (Fpath.t, string option) IlluaminateData.Key.t =
+  let module Fpath = struct
+    include Fpath
+
+    let hash p = String.hash (Fpath.to_string p)
+  end in
+  IlluaminateData.Key.deferred ~name:(__MODULE__ ^ ".find_asset") ~eq:(Option.equal String.equal)
+    ~key:(module Fpath)
+    ()
+
+(** Register a handler for {!find_asset}. *)
+let add_find_asset dest builder =
+  let copy_asset path _ : string option =
+    let path' = Fpath.to_string path in
+    if not (Sys.file_exists path') then None
+    else
+      let digest = hash_file path in
+      let dest_name =
+        let path, ext = Fpath.split_ext path in
+        Format.sprintf "%s-%s%s" (Fpath.filename path) digest ext
+      in
+      let dest_file = Fpath.(dest / dest_name) in
+      In_channel.with_open_bin path' (fun inp ->
+          Out_channel.with_open_bin (Fpath.to_string dest_file) (fun out -> CCIO.copy_into inp out));
+      Some dest_name
+  in
+  IlluaminateData.Builder.oracle find_asset copy_asset builder

src/doc_emit/html_loader.ml

@@ -17,7 +17,7 @@ let load_file ~options path =
           }
         in
         IlluaminateSemantics.Doc.Parser.parse_description contents
-        |> Lift.markdown lifter |> Html_md.md ~options |> Result.ok
+        |> Lift.markdown lifter |> Html_md.md ~path ~options |> Result.ok
     | ".txt" | "" -> create_node ~tag:"pre" ~children:[ str contents ] () |> Result.ok
     | ext ->
         Format.asprintf "Cannot handle documentation index '%a' (unknown file extension %S)\n%!"

src/doc_emit/html_md.ml

@@ -68,6 +68,51 @@ let emit_link ~options c l =
         | Some _ -> emit_invalid_admonition c l; true
         | None -> false))
 
+(** If [link] is a relative path, then resolve the file (relative to [md_file]) and
+    {!Html_assets.find_asset copy it into the destination directory} *)
+let resolve_asset_link ~md_file ~(options : Html_options.t) link =
+  let uri = Uri.of_string link in
+  match
+    (Uri.scheme uri, Uri.userinfo uri, Uri.host uri, Uri.port uri, Uri.query uri, Uri.fragment uri)
+  with
+  | None, None, None, None, [], None -> (
+    match Fpath.of_string (Uri.path uri) with
+    | Ok path when Fpath.is_rel path ->
+        let path = Fpath.(parent md_file // path |> normalize) in
+        IlluaminateData.get options.data Html_assets.find_asset path |> Option.map options.resolve
+    | _ -> None)
+  | _ -> None
+
+let emit_basic_image c ~link ~title ~text =
+  let plain_text i =
+    let lines = Inline.to_plain_text ~break_on_soft:false i in
+    String.concat "\n" (List.map (String.concat "") lines)
+  in
+  let title =
+    match title with
+    | None -> ""
+    | Some title -> String.concat "\n" (List.map (fun (_, (t, _)) -> t) title)
+  in
+  C.string c "<img src=\"";
+  H.pct_encoded_string c link;
+  C.string c "\" alt=\"";
+  H.html_escaped_string c (plain_text text);
+  C.byte c '\"';
+  if title <> "" then (C.string c " title=\""; H.html_escaped_string c title; C.byte c '\"');
+  C.string c "/>"
+
+let emit_image ~path ~(options : Html_options.t) (c : Cmarkit_renderer.context) l =
+  match (path, Inline.Link.reference_definition (C.get_defs c) l) with
+  | Some md_file, Some (Link_definition.Def (ld, _)) -> (
+    match
+      Option.bind (Link_definition.dest ld) (fun (ld, _) -> resolve_asset_link ~md_file ~options ld)
+    with
+    | Some link ->
+        emit_basic_image c ~link ~title:(Link_definition.title ld) ~text:(Inline.Link.text l);
+        true
+    | None -> false)
+  | _ -> false
+
 let emit_code_block ~options c block =
   let language, extra =
     Block.Code_block.info_string block
@@ -139,49 +184,107 @@ let emit_block_quote c body =
       H.admonition c ~level ?label contents;
       true
 
-let custom_html ~options =
+module Stream = struct
+  type t =
+    { mutable index : int;
+      mutable lines : Cmarkit.Block_line.t list
+    }
+
+  let stream lines =
+    let state = { index = 0; lines } in
+    let rec poll () =
+      match state.lines with
+      | [] -> None
+      | (l, _) :: ls ->
+          let index = state.index in
+          if index >= String.length l then (
+            state.index <- 0;
+            state.lines <- ls;
+            poll ())
+          else (
+            state.index <- index + 1;
+            Some l.[index])
+    in
+    Markup.stream poll
+end
+
+let emit_block_html ~path ~options c block =
+  match path with
+  | None -> false
+  | Some md_file ->
+      let rec set_assoc k v = function
+        | [] -> failwith "Did not find key"
+        | (k', _) :: xs when k = k' -> (k, v) :: xs
+        | kv :: xs -> kv :: set_assoc k v xs
+      in
+      let map_signal : Markup.signal -> Markup.signal = function
+        | `Start_element (name, attrs) as e ->
+            if name = (Markup.Ns.html, "img") then
+              match
+                List.assoc_opt ("", "src") attrs
+                |> CCOption.flat_map (resolve_asset_link ~md_file ~options)
+              with
+              | Some link -> `Start_element (name, set_assoc ("", "src") link attrs)
+              | None -> e
+            else e
+        | e -> e
+      in
+      Stream.stream block
+      |> Markup.parse_html ~context:(`Fragment "body")
+      |> Markup.signals |> Markup.map map_signal |> Markup.write_html
+      |> Markup.iter (fun chr -> Buffer.add_char (C.buffer c) chr);
+      true
+
+let custom_html ~path ~options =
   let inline c = function
     | Inline.Link (l, _) -> emit_link ~options c l
+    | Inline.Image (l, _) -> emit_image ~path ~options c l
     | _ -> false (* let the default HTML renderer handle that *)
   in
   let block c = function
     | Block.Code_block (block, _) -> emit_code_block ~options c block; true
     | Block.Block_quote (block, _) -> emit_block_quote c (Block.Block_quote.block block)
+    | Block.Html_block (block, _) -> emit_block_html ~path ~options c block
     | _ -> false (* let the default HTML renderer handle that *)
   in
   Cmarkit_renderer.make ~inline ~block ()
 
-let renderer ~options =
-  Cmarkit_renderer.compose (Cmarkit_html.renderer ~safe:false ()) (custom_html ~options)
+let renderer ~path ~options =
+  Cmarkit_renderer.compose (Cmarkit_html.renderer ~safe:false ()) (custom_html ~path ~options)
 
 (** Render an inline fragment of a markdown document. *)
-let render_inline ~options ~doc inline =
+let render_inline ~path ~options ~doc inline =
   let b = Buffer.create 16 in
-  let ctx = Cmarkit_renderer.Context.make (renderer ~options) b in
+  let ctx = Cmarkit_renderer.Context.make (renderer ~path ~options) b in
   Cmarkit_renderer.Context.init ctx (S.Markdown.doc doc);
   Cmarkit_renderer.Context.inline ctx inline;
   Buffer.contents b |> raw
 
 (** Render a markdown document to a HTML {!node}.*)
-let md ~options doc =
-  S.Markdown.doc doc |> Cmarkit_renderer.doc_to_string (renderer ~options) |> raw
+let md ?path ~options doc =
+  S.Markdown.doc doc |> Cmarkit_renderer.doc_to_string (renderer ~path ~options) |> raw
 
 (** Render a markdown document to a HTML {!node}, trying to unwrap documents containing a single
     paragraph. *)
-let md_inline ~options doc =
+let md_inline ~path ~options doc =
   match S.Markdown.as_single_paragraph doc with
-  | Some t -> render_inline ~options ~doc t
-  | None -> md ~options doc
+  | Some t -> render_inline ~path ~options ~doc t
+  | None -> md ?path ~options doc
+
+let description_file (d : S.description) =
+  let file = A.Comment_lines.span d.description_pos |> IlluaminateCore.Span.filename in
+  file.path
 
 let show_desc ~options = function
   | None -> nil
-  | Some (d : S.description) -> md ~options d.description
+  | Some (d : S.description) -> md ?path:(description_file d) ~options d.description
 
 let show_summary ~options = function
   | None -> nil
   | Some (d : S.description) ->
-      Helpers.get_summary d.description |> render_inline ~options ~doc:d.description
+      Helpers.get_summary d.description
+      |> render_inline ~path:(description_file d) ~options ~doc:d.description
 
 let show_desc_inline ~options = function
   | None -> nil
-  | Some (d : S.description) -> md_inline ~options d.description
+  | Some (d : S.description) -> md_inline ~path:(description_file d) ~options d.description

src/doc_emit/html_md.mli

@@ -3,7 +3,7 @@
 open IlluaminateSemantics
 
 (** Render a markdown document to a HTML node.*)
-val md : options:Html_options.t -> Doc.Syntax.Markdown.t -> Html.Default.node
+val md : ?path:Fpath.t -> options:Html_options.t -> Doc.Syntax.Markdown.t -> Html.Default.node
 
 (** Render a description to a HTML node. *)
 val show_desc : options:Html_options.t -> Doc.Syntax.description option -> Html.Default.node

src/doc_emit/illuaminateDocEmit.ml

@@ -1,6 +1,7 @@
 module Html = struct
   module Options = Html_options
   module Highlight = Html_highlight
+  module Assets = Html_assets
   include Html_main
   include Html_loader
 

src/doc_emit/illuaminateDocEmit.mli

@@ -25,6 +25,7 @@ module Html : sig
       ?attrs:(string * string option) list -> options:Html_options.t -> string -> Html.Default.node
   end
 
+  module Assets = Html_assets
   module Doc := IlluaminateSemantics.Doc
 
   type page_list :=