Refactor IO functions and fix invalid IOs in gen_rules

src/action.ml

@@ -302,25 +302,25 @@ module Mini_shexp = struct
          | None -> print_string str; flush stdout
          | Some (_, oc) -> output_string oc str)
     | Cat fn ->
-      with_file_in (Path.to_string fn) ~f:(fun ic ->
+      Io.with_file_in (Path.to_string fn) ~f:(fun ic ->
         let oc =
           match stdout_to with
           | None -> stdout
           | Some (_, oc) -> oc
         in
-        copy_channels ic oc);
+        Io.copy_channels ic oc);
       return ()
     | Create_file fn ->
       let fn = Path.to_string fn in
       if Sys.file_exists fn then Sys.remove fn;
       Unix.close (Unix.openfile fn [O_CREAT; O_TRUNC; O_WRONLY] 0o666);
       return ()
     | Copy (src, dst) ->
-      copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
+      Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
       return ()
     | Symlink (src, dst) ->
       if Sys.win32 then
-        copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
+        Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
       else begin
         let src =
           if Path.is_root dst then
@@ -340,11 +340,11 @@ module Mini_shexp = struct
       end;
       return ()
     | Copy_and_add_line_directive (src, dst) ->
-      with_file_in (Path.to_string src) ~f:(fun ic ->
-        with_file_out (Path.to_string dst) ~f:(fun oc ->
+      Io.with_file_in (Path.to_string src) ~f:(fun ic ->
+        Io.with_file_out (Path.to_string dst) ~f:(fun oc ->
           let fn = Path.drop_build_context src in
           Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
-          copy_channels ic oc));
+          Io.copy_channels ic oc));
       return ()
     | System cmd ->
       let path, arg =
@@ -357,18 +357,18 @@ module Mini_shexp = struct
         ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
     | Update_file (fn, s) ->
       let fn = Path.to_string fn in
-      if Sys.file_exists fn && read_file fn = s then
+      if Sys.file_exists fn && Io.read_file fn = s then
         ()
       else
-        write_file fn s;
+        Io.write_file fn s;
       return ()
     | Rename (src, dst) ->
       Unix.rename (Path.to_string src) (Path.to_string dst);
       return ()
 
   and redirect outputs fn t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
     let fn = Path.to_string fn in
-    let oc = open_out_bin fn in
+    let oc = Io.open_out fn in
     let out = Some (fn, oc) in
     let stdout_to, stderr_to =
       match outputs with

src/build_system.ml

@@ -237,8 +237,8 @@ module Build_exec = struct
         (a, b)
       | Paths _ -> x
       | Paths_glob _ -> x
-      | Contents p -> read_file (Path.to_string p)
-      | Lines_of p -> lines_of_file (Path.to_string p)
+      | Contents p -> Io.read_file (Path.to_string p)
+      | Lines_of p -> Io.lines_of_file (Path.to_string p)
       | Vpath (Vspec.T (fn, kind)) ->
         let file : b File_spec.t = get_file bs fn (Sexp_file kind) in
         Option.value_exn file.data
@@ -524,12 +524,12 @@ module Trace = struct
           Sexp.List [ Atom (Path.to_string path); Atom (Digest.to_hex hash) ]))
     in
     if Sys.file_exists "_build" then
-      write_file file (Sexp.to_string sexp)
+      Io.write_file file (Sexp.to_string sexp)
 
   let load () =
     let trace = Hashtbl.create 1024 in
     if Sys.file_exists file then begin
-      let sexp = Sexp_load.single file in
+      let sexp = Sexp_lexer.Load.single file in
       let bindings =
         let open Sexp.Of_sexp in
         list (pair Path.t (fun s -> Digest.from_hex (string s))) sexp

src/context.ml

@@ -118,7 +118,7 @@ let compare a b = compare a.name b.name
 
 let get_arch_sixtyfour stdlib_dir =
   let config_h = Path.relative stdlib_dir "caml/config.h" in
-  List.exists (lines_of_file (Path.to_string config_h)) ~f:(fun line ->
+  List.exists (Io.lines_of_file (Path.to_string config_h)) ~f:(fun line ->
     match String.extract_blank_separated_words line with
     | ["#define"; "ARCH_SIXTYFOUR"] -> true
     | _ -> false)

src/future.ml

@@ -245,12 +245,12 @@ let run_capture_gen ?dir ?env ?(purpose=Internal_job) fail_mode prog args ~f =
       Temp.destroy fn;
       x)
 
-let run_capture       = run_capture_gen ~f:read_file
-let run_capture_lines = run_capture_gen ~f:lines_of_file
+let run_capture       = run_capture_gen ~f:Io.read_file
+let run_capture_lines = run_capture_gen ~f:Io.lines_of_file
 
 let run_capture_line ?dir ?env ?(purpose=Internal_job) fail_mode prog args =
   run_capture_gen ?dir ?env ~purpose fail_mode prog args ~f:(fun fn ->
-    match lines_of_file fn with
+    match Io.lines_of_file fn with
     | [x] -> x
     | l ->
       let cmdline =
@@ -414,7 +414,7 @@ module Scheduler = struct
       match job.output_filename with
       | None -> ""
       | Some fn ->
-        let s = read_file fn in
+        let s = Io.read_file fn in
         Temp.destroy fn;
         let len = String.length s in
         if len > 0 && s.[len - 1] <> '\n' then

src/gen_rules.ml

@@ -1,6 +1,7 @@
 open Import
 open Jbuild_types
 open Build.O
+open! No_io
 
 (* +-----------------------------------------------------------------+
    | Utils                                                           |
@@ -666,21 +667,22 @@ module Gen(P : Params) = struct
           match pkg.version_from_opam_file with
           | Some s -> Build.return (Some s)
           | None ->
-            let candicates =
+            let rec loop = function
+              | [] -> Build.return None
+              | candidate :: rest ->
+                let p = Path.relative path candidate in
+                Build.if_file_exists p
+                  ~then_:(Build.lines_of p
+                          >>^ function
+                          | ver :: _ -> Some ver
+                          | _ -> Some "")
+                  ~else_:(loop rest)
+            in
+            loop
               [ pkg.name ^ ".version"
               ; "version"
               ; "VERSION"
               ]
-            in
-            match List.find candicates ~f:(fun fn -> String_set.mem fn files) with
-            | None -> Build.return None
-            | Some fn ->
-              let p = Path.relative path fn in
-              Build.path p
-              >>^ fun () ->
-              match lines_of_file (Path.to_string p) with
-              | ver :: _ -> Some ver
-              | _ -> Some ""
         in
         Super_context.Pkg_version.set sctx pkg get
       in

src/import.ml

@@ -397,43 +397,6 @@ let protectx x ~finally ~f =
   | y           -> finally x; y
   | exception e -> finally x; raise e
 
-let with_file_in ?(binary=true) fn ~f =
-  protectx ((if binary then open_in_bin else open_in) fn)
-    ~finally:close_in ~f
-
-let with_file_out ?(binary=true)fn ~f =
-  protectx ((if binary then open_out_bin else open_out) fn)
-    ~finally:close_out ~f
-
-let with_lexbuf_from_file fn ~f =
-  with_file_in fn ~f:(fun ic ->
-    let lb = Lexing.from_channel ic in
-    lb.lex_curr_p <-
-      { pos_fname = fn
-      ; pos_lnum  = 1
-      ; pos_bol   = 0
-      ; pos_cnum  = 0
-      };
-    f lb)
-
-let input_lines =
-  let rec loop ic acc =
-    match input_line ic with
-    | exception End_of_file -> List.rev acc
-    | line ->
-       loop ic (line :: acc)
-  in
-  fun ic -> loop ic []
-
-let read_file fn =
-  protectx (open_in_bin fn) ~finally:close_in ~f:(fun ic ->
-    let len = in_channel_length ic in
-    really_input_string ic len)
-
-let lines_of_file fn = with_file_in fn ~f:input_lines ~binary:false
-
-let write_file fn data = with_file_out fn ~f:(fun oc -> output_string oc data)
-
 exception Fatal_error of string
 let die_buf = Buffer.create 128
 let die_ppf (* Referenced in Ansi_color *) = Format.formatter_of_buffer die_buf
@@ -451,27 +414,6 @@ let warn fmt =
     prerr_endline ("Warning: jbuild: " ^ msg))
     fmt
 
-let copy_channels =
-  let buf_len = 65536 in
-  let buf = Bytes.create buf_len in
-  let rec loop ic oc =
-    match input ic buf 0 buf_len with
-    | 0 -> ()
-    | n -> output oc buf 0 n; loop ic oc
-  in
-  loop
-
-let copy_file ~src ~dst =
-  with_file_in src ~f:(fun ic ->
-    let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm in
-    protectx (open_out_gen
-                [Open_wronly; Open_creat; Open_trunc; Open_binary]
-                perm
-                dst)
-      ~finally:close_out
-      ~f:(fun oc ->
-        copy_channels ic oc))
-
 module Staged : sig
   type +'a t
   val unstage : 'a t -> 'a
@@ -516,3 +458,17 @@ let hint name candidates =
       | [] -> ""
     in
     sprintf "\nHint: did you mean %s?" (mk_hint l)
+
+(* Disable file operations to force to use the IO module *)
+let open_in      = `Use_Io
+let open_in_bin  = `Use_Io
+let open_in_gen  = `Use_Io
+let open_out     = `Use_Io
+let open_out_bin = `Use_Io
+let open_out_gen = `Use_Io
+
+(* We open this module at the top of module generating rules, to make sure they don't do
+   Io manually *)
+module No_io = struct
+  module Io = struct end
+end

src/io.ml

@@ -0,0 +1,68 @@
+open Import
+
+module P = Pervasives
+
+let open_in ?(binary=true) fn =
+  if binary then P.open_in_bin fn else P.open_in fn
+
+let open_out ?(binary=true) fn =
+  if binary then P.open_out_bin fn else P.open_out fn
+
+let close_in  = close_in
+let close_out = close_out
+
+let with_file_in ?binary fn ~f =
+  protectx (open_in ?binary fn) ~finally:close_in ~f
+
+let with_file_out ?binary fn ~f =
+  protectx (open_out ?binary fn) ~finally:close_out ~f
+
+let with_lexbuf_from_file fn ~f =
+  with_file_in fn ~f:(fun ic ->
+    let lb = Lexing.from_channel ic in
+    lb.lex_curr_p <-
+      { pos_fname = fn
+      ; pos_lnum  = 1
+      ; pos_bol   = 0
+      ; pos_cnum  = 0
+      };
+    f lb)
+
+let input_lines =
+  let rec loop ic acc =
+    match input_line ic with
+    | exception End_of_file -> List.rev acc
+    | line ->
+       loop ic (line :: acc)
+  in
+  fun ic -> loop ic []
+
+let read_file fn =
+  with_file_in fn ~f:(fun ic ->
+    let len = in_channel_length ic in
+    really_input_string ic len)
+
+let lines_of_file fn = with_file_in fn ~f:input_lines ~binary:false
+
+let write_file fn data = with_file_out fn ~f:(fun oc -> output_string oc data)
+
+let copy_channels =
+  let buf_len = 65536 in
+  let buf = Bytes.create buf_len in
+  let rec loop ic oc =
+    match input ic buf 0 buf_len with
+    | 0 -> ()
+    | n -> output oc buf 0 n; loop ic oc
+  in
+  loop
+
+let copy_file ~src ~dst =
+  with_file_in src ~f:(fun ic ->
+    let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm in
+    protectx (P.open_out_gen
+                [Open_wronly; Open_creat; Open_trunc; Open_binary]
+                perm
+                dst)
+      ~finally:close_out
+      ~f:(fun oc ->
+        copy_channels ic oc))

src/io.mli

@@ -0,0 +1,21 @@
+(** IO operations *)
+
+val open_in  : ?binary:bool (* default true *) -> string -> in_channel
+val open_out : ?binary:bool (* default true *) -> string -> out_channel
+
+val close_in  : in_channel  -> unit
+val close_out : out_channel -> unit
+
+val with_file_in  : ?binary:bool (* default true *) -> string -> f:(in_channel -> 'a) -> 'a
+val with_file_out : ?binary:bool (* default true *) -> string -> f:(out_channel -> 'a) -> 'a
+
+val with_lexbuf_from_file : string -> f:(Lexing.lexbuf -> 'a) -> 'a
+
+val lines_of_file : string -> string list
+
+val read_file : string -> string
+val write_file : string -> string -> unit
+
+val copy_channels : in_channel -> out_channel -> unit
+
+val copy_file : src:string -> dst:string -> unit

src/jbuild_load.ml

@@ -31,8 +31,8 @@ module Jbuilds = struct
 
   let create_plugin_wrapper (context : Context.t) ~exec_dir ~plugin ~wrapper ~target =
     let plugin = Path.to_string plugin in
-    let plugin_contents = read_file plugin in
-    with_file_out (Path.to_string wrapper) ~f:(fun oc ->
+    let plugin_contents = Io.read_file plugin in
+    Io.with_file_out (Path.to_string wrapper) ~f:(fun oc ->
       Printf.fprintf oc {|
 let () = Hashtbl.add Toploop.directive_table "require" (Toploop.Directive_string ignore)
 module Jbuild_plugin = struct
@@ -117,7 +117,7 @@ end
           die "@{<error>Error:@} %s failed to produce a valid jbuild file.\n\
                Did you forgot to call [Jbuild_plugin.V*.send]?"
             (Path.to_string file);
-        let sexps = Sexp_load.many (Path.to_string generated_jbuild) in
+        let sexps = Sexp_lexer.Load.many (Path.to_string generated_jbuild) in
         return (dir, pkgs_ctx, Stanzas.parse pkgs_ctx sexps))
     |> Future.all
 end
@@ -132,7 +132,7 @@ type conf =
 let load ~dir ~visible_packages ~closest_packages =
   let file = Path.relative dir "jbuild" in
   let pkgs = { Pkgs. visible_packages; closest_packages } in
-  match Sexp_load.many_or_ocaml_script (Path.to_string file) with
+  match Sexp_lexer.Load.many_or_ocaml_script (Path.to_string file) with
   | Sexps sexps ->
     Jbuilds.Literal (dir, pkgs, Stanzas.parse pkgs sexps)
   | Ocaml_script ->
@@ -164,7 +164,7 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) () =
       if String_set.mem "jbuild-ignore" files then
         let ignore_set =
           String_set.of_list
-            (lines_of_file (Path.to_string (Path.relative path "jbuild-ignore")))
+            (Io.lines_of_file (Path.to_string (Path.relative path "jbuild-ignore")))
         in
         Dont_recurse_in
           (ignore_set,

src/js_of_ocaml_rules.ml

@@ -1,4 +1,5 @@
 open Import
+open! No_io
 
 module SC = Super_context