driver: Refactor Landing_pages to use Format

Util.write_file is refactored to be more suitable.

src/driver/compile.ml

@@ -1,5 +1,7 @@
 (* compile *)
 
+open Bos
+
 type compiled = Odoc_unit.t
 
 let mk_byhash (pkgs : Odoc_unit.intf Odoc_unit.unit list) =
@@ -52,8 +54,7 @@ let unmarshal filename : partial =
     (fun () -> Marshal.from_channel ic)
 
 let marshal (v : partial) filename =
-  let p = Fpath.parent filename in
-  Util.mkdir_p p;
+  let _ = OS.Dir.create (Fpath.parent filename) |> Result.get_ok in
   let oc = open_out_bin (Fpath.to_string filename) in
   Fun.protect
     ~finally:(fun () -> close_out oc)
@@ -63,10 +64,10 @@ let find_partials odoc_dir : Odoc_unit.intf Odoc_unit.unit Util.StringMap.t * _
     =
   let tbl = Hashtbl.create 1000 in
   let hashes_result =
-    Bos.OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
+    OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
       (fun p hashes ->
         let index_m = Fpath.( / ) p "index.m" in
-        match Bos.OS.File.exists index_m with
+        match OS.File.exists index_m with
         | Ok true ->
             let tbl', hashes' = unmarshal index_m in
             List.iter
@@ -207,7 +208,7 @@ let sherlodoc_index_one ~output_dir (index : Odoc_unit.index) =
   let rel_path = Fpath.(index.search_dir / "sherlodoc_db.js") in
   let dst = Fpath.(output_dir // rel_path) in
   let dst_dir, _ = Fpath.split_base dst in
-  Util.mkdir_p dst_dir;
+  let _ = OS.Dir.create dst_dir |> Result.get_ok in
   Sherlodoc.index ~format:`js ~inputs ~dst ();
   rel_path
 

src/driver/dune

@@ -13,4 +13,5 @@
   opam-format
   logs
   logs.fmt
-  eio_main))
+  eio_main
+  odoc_utils))

src/driver/landing_pages.ml

@@ -6,7 +6,9 @@ let make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir rel_path ~content
   let input_file = Fpath.(mld_dir // rel_path / "index.mld") in
   let odoc_file = Fpath.(odoc_dir // rel_path / "page-index.odoc") in
   let odocl_file = Fpath.(odocl_dir // rel_path / "page-index.odocl") in
-  let () = Util.write_file input_file (String.split_on_char '\n' content) in
+  Util.with_out_to input_file (fun oc ->
+      content (Format.formatter_of_out_channel oc))
+  |> Result.get_ok;
   let parent_id = rel_path |> Odoc.Id.of_fpath in
   {
     parent_id;
@@ -22,26 +24,18 @@ let make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir rel_path ~content
     kind = `Mld;
   }
 
+let fpf = Format.fprintf
+
 module PackageLanding = struct
-  let content pkg =
-    let title = Format.sprintf "{0 %s}\n" pkg.name in
-    let documentation =
-      match pkg.mlds with
-      | _ :: _ ->
-          Format.sprintf
-            "{1 Documentation pages}\n\n\
-             {{!/%s/doc/index}Documentation for %s}\n"
-            pkg.name pkg.name
-      | [] -> ""
-    in
-    let libraries =
-      match pkg.libraries with
-      | [] -> ""
-      | _ :: _ ->
-          Format.sprintf "{1 Libraries}\n\n{{!/%s/lib/index}Libraries for %s}\n"
-            pkg.name pkg.name
-    in
-    title ^ documentation ^ libraries
+  let content pkg ppf =
+    fpf ppf "{0 %s}\n" pkg.name;
+    if not (List.is_empty pkg.mlds) then
+      fpf ppf
+        "{1 Documentation pages}@\n@\n{{!/%s/doc/index}Documentation for %s}@\n"
+        pkg.name pkg.name;
+    if not (List.is_empty pkg.libraries) then
+      fpf ppf "{1 Libraries}@\n@\n{{!/%s/lib/index}Libraries for %s}@\n"
+        pkg.name pkg.name
 
   let page ~odoc_dir ~odocl_dir ~mld_dir ~output_dir ~pkg =
     let content = content pkg in
@@ -54,16 +48,15 @@ module PackageLanding = struct
 end
 
 module PackageList = struct
-  let content all =
+  let content all ppf =
     let sorted_packages =
       all |> List.sort (fun n1 n2 -> String.compare n1.name n2.name)
     in
-    let title = "{0 List of all packages}\n" in
-    let s_of_pkg pkg =
-      Format.sprintf "- {{!/__driver/%s/index}%s}" pkg.name pkg.name
+    fpf ppf "{0 List of all packages}@\n";
+    let print_pkg pkg =
+      fpf ppf "- {{!/__driver/%s/index}%s}@\n" pkg.name pkg.name
     in
-    let pkg_ul = sorted_packages |> List.map s_of_pkg |> String.concat "\n" in
-    title ^ pkg_ul
+    List.iter print_pkg sorted_packages
 
   let page ~mld_dir ~odoc_dir ~odocl_dir ~output_dir all =
     let content = content all in
@@ -77,16 +70,13 @@ module PackageList = struct
 end
 
 module LibraryLanding = struct
-  let content lib =
-    let title = Format.sprintf "{0 %s}\n" lib.lib_name in
-    let s_of_module m =
-      if m.m_hidden then None
-      else Some (Format.sprintf "- {!%s}" m.Packages.m_name)
+  let content lib ppf =
+    fpf ppf "{0 %s}@\n" lib.lib_name;
+    let print_module m =
+      if not m.m_hidden then fpf ppf "- {!%s}@\n" m.Packages.m_name
     in
-    let modules =
-      lib.modules |> List.filter_map s_of_module |> String.concat "\n"
-    in
-    title ^ modules
+    List.iter print_module lib.modules
+
   let page ~pkg ~odoc_dir ~odocl_dir ~mld_dir ~output_dir lib =
     let content = content lib in
     let rel_path = Fpath.(v pkg.name / "lib" / lib.lib_name) in
@@ -99,13 +89,12 @@ module LibraryLanding = struct
 end
 
 module PackageLibLanding = struct
-  let content pkg =
-    let title = Format.sprintf "{0 %s}\n" pkg.name in
-    let s_of_lib (lib : Packages.libty) =
-      Format.sprintf "- {{!/%s/%s/index}%s}" pkg.name lib.lib_name lib.lib_name
+  let content pkg ppf =
+    fpf ppf "{0 %s}@\n" pkg.name;
+    let print_lib (lib : Packages.libty) =
+      fpf ppf "- {{!/%s/%s/index}%s}@\n" pkg.name lib.lib_name lib.lib_name
     in
-    let libraries = pkg.libraries |> List.map s_of_lib |> String.concat "\n" in
-    title ^ libraries
+    List.iter print_lib pkg.libraries
 
   let page ~pkg ~odoc_dir ~odocl_dir ~mld_dir ~output_dir =
     let content = content pkg in

src/driver/util.ml

@@ -1,3 +1,4 @@
+open Odoc_utils
 open Bos
 
 module StringSet = Set.Make (String)
@@ -17,29 +18,18 @@ let lines_of_process cmd =
   | Ok x -> x
   | Error (`Msg e) -> failwith ("Error: " ^ e)
 
-let mkdir_p d =
-  let segs =
-    Fpath.segs (Fpath.normalize d) |> List.filter (fun s -> String.length s > 0)
-  in
-  let _ =
-    List.fold_left
-      (fun path seg ->
-        let d = Fpath.(path // v seg) in
-        try
-          Unix.mkdir (Fpath.to_string d) 0o755;
-          d
-        with
-        | Unix.Unix_error (Unix.EEXIST, _, _) -> d
-        | exn -> raise exn)
-      (Fpath.v ".") segs
-  in
-  ()
-
-let write_file filename lines =
-  let dir = fst (Fpath.split_base filename) in
-  mkdir_p dir;
-  let oc = open_out (Fpath.to_string filename) in
-  List.iter (fun line -> Printf.fprintf oc "%s\n" line) lines;
-  close_out oc
+(** Opens a file for writing and calls [f]. The destination directory is created
+    if needed. *)
+let with_out_to filename f =
+  let open ResultMonad in
+  OS.Dir.create (Fpath.parent filename) >>= fun _ ->
+  OS.File.with_oc filename
+    (fun oc () ->
+      f oc;
+      Ok ())
+    ()
+  >>= fun r ->
+  Result.get_ok r;
+  Ok ()
 
 let cp src dst = assert (lines_of_process Cmd.(v "cp" % src % dst) = [])