Refactor IO functions and fix invalid IOs in gen_rules

src/action.ml

@@ -302,13 +302,13 @@ 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
@@ -316,11 +316,11 @@ module Mini_shexp = struct
       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,10 +357,10 @@ 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);
@@ -368,7 +368,7 @@ module Mini_shexp = struct
 
   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
 

src/log.ml

@@ -13,7 +13,7 @@ let no_log = None
 let create () =
   if not (Sys.file_exists "_build") then
     Unix.mkdir "_build" 0o777;
-  let oc = open_out_bin "_build/log" in
+  let oc = Io.open_out "_build/log" in
   Printf.fprintf oc "# %s\n%!"
     (String.concat (List.map (Array.to_list Sys.argv) ~f:quote_for_shell) ~sep:" ");
   let buf = Buffer.create 1024 in

src/merlin.ml

@@ -1,5 +1,6 @@
 open Import
 open Build.O
+open! No_io
 
 module SC = Super_context
 

src/meta.ml

@@ -103,7 +103,7 @@ module Parse = struct
 end
 
 let load fn =
-  with_lexbuf_from_file fn ~f:(fun lb ->
+  Io.with_lexbuf_from_file fn ~f:(fun lb ->
       Parse.entries lb 0 [])
 
 module Simplified = struct

src/module_compilation.ml

@@ -1,5 +1,6 @@
 open Import
 open Build.O
+open! No_io
 
 module SC = Super_context
 

src/opam_file.ml

@@ -5,7 +5,7 @@ open OpamParserTypes
 type t = opamfile
 
 let load fn =
-  with_lexbuf_from_file fn ~f:(fun lb ->
+  Io.with_lexbuf_from_file fn ~f:(fun lb ->
     try
       OpamBaseParser.main OpamLexer.token lb fn
     with

src/sexp_lexer.mli

@@ -6,3 +6,9 @@ type sexps_or_ocaml_script =
   | Ocaml_script
 
 val many_or_ocaml_script : Lexing.lexbuf -> sexps_or_ocaml_script
+
+module Load : sig
+  val single : string -> Sexp.Ast.t
+  val many   : string -> Sexp.Ast.t list
+  val many_or_ocaml_script : string -> sexps_or_ocaml_script
+end

src/sexp_lexer.mll

@@ -202,4 +202,15 @@ and is_ocaml_script = parse
     match is_ocaml_script lexbuf with
     | true -> Ocaml_script
     | false -> Sexps (many lexbuf)
+
+  module Load = struct
+    let single fn =
+      Io.with_lexbuf_from_file fn ~f:single
+
+    let many fn =
+      Io.with_lexbuf_from_file fn ~f:many
+
+    let many_or_ocaml_script fn =
+      Io.with_lexbuf_from_file fn ~f:many_or_ocaml_script
+  end
 }

src/sexp_load.ml

@@ -1,10 +0,0 @@
-open Import
-
-let single fn =
-  with_lexbuf_from_file fn ~f:Sexp_lexer.single
-
-let many fn =
-  with_lexbuf_from_file fn ~f:Sexp_lexer.many
-
-let many_or_ocaml_script fn =
-  with_lexbuf_from_file fn ~f:Sexp_lexer.many_or_ocaml_script

src/sexp_load.mli

@@ -1,5 +0,0 @@
-open! Import
-
-val single : string -> Sexp.Ast.t
-val many   : string -> Sexp.Ast.t list
-val many_or_ocaml_script : string -> Sexp_lexer.sexps_or_ocaml_script

src/vfile_kind.ml

@@ -55,7 +55,7 @@ struct
   let to_string path x = To_sexp.t path x |> Sexp.to_string
 
   let load path =
-    Of_sexp.t path (Sexp_load.single (Path.to_string path))
+    Of_sexp.t path (Sexp_lexer.Load.single (Path.to_string path))
 end
 
 

src/watermarks.ml

@@ -154,7 +154,7 @@ let subst_string s ~fname ~map =
     Some (Buffer.contents buf)
 
 let subst_file fn ~map =
-  let s = read_file fn in
+  let s = Io.read_file fn in
   let s =
     if Filename.dirname fn = "." && String.is_suffix fn ~suffix:".opam" then
       "version: \"%%" ^ "VERSION_NUM" ^ "%%\"\n" ^ s
@@ -163,7 +163,7 @@ let subst_file fn ~map =
   in
   match subst_string s ~map ~fname:fn with
   | None -> ()
-  | Some s -> write_file fn s
+  | Some s -> Io.write_file fn s
 
 let get_name ~files ?name () =
   let package_names =

src/workspace.ml

@@ -78,4 +78,4 @@ let t sexps =
   ; contexts       = List.rev contexts
   }
 
-let load fn = t (Sexp_load.many fn)
+let load fn = t (Sexp_lexer.Load.many fn)