diff --git a/src/action.ml b/src/action.ml index 9b0a3ae0..132316a0 100644 --- a/src/action.ml +++ b/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 diff --git a/src/build_system.ml b/src/build_system.ml index 399df4da..b20f6a7c 100644 --- a/src/build_system.ml +++ b/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 diff --git a/src/context.ml b/src/context.ml index d51f54de..f3cb3034 100644 --- a/src/context.ml +++ b/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) diff --git a/src/future.ml b/src/future.ml index b89256f6..4f7afc6d 100644 --- a/src/future.ml +++ b/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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 5a9c53a5..bfa2ce4b 100644 --- a/src/gen_rules.ml +++ b/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 diff --git a/src/import.ml b/src/import.ml index 8a566d7d..9a7dbd9c 100644 --- a/src/import.ml +++ b/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 diff --git a/src/io.ml b/src/io.ml new file mode 100644 index 00000000..1e0fdf09 --- /dev/null +++ b/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)) diff --git a/src/io.mli b/src/io.mli new file mode 100644 index 00000000..86ecc556 --- /dev/null +++ b/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 diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index ca76913d..a821f5e0 100644 --- a/src/jbuild_load.ml +++ b/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:@} %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, diff --git a/src/js_of_ocaml_rules.ml b/src/js_of_ocaml_rules.ml index f69a6caa..d78a2b4e 100644 --- a/src/js_of_ocaml_rules.ml +++ b/src/js_of_ocaml_rules.ml @@ -1,4 +1,5 @@ open Import +open! No_io module SC = Super_context diff --git a/src/log.ml b/src/log.ml index 513553c7..f842af60 100644 --- a/src/log.ml +++ b/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 diff --git a/src/merlin.ml b/src/merlin.ml index 7e2650be..bdb9351b 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -1,5 +1,6 @@ open Import open Build.O +open! No_io module SC = Super_context diff --git a/src/meta.ml b/src/meta.ml index ea83994d..28e3b281 100644 --- a/src/meta.ml +++ b/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 diff --git a/src/module_compilation.ml b/src/module_compilation.ml index 44597fad..e169918d 100644 --- a/src/module_compilation.ml +++ b/src/module_compilation.ml @@ -1,5 +1,6 @@ open Import open Build.O +open! No_io module SC = Super_context diff --git a/src/opam_file.ml b/src/opam_file.ml index 87907e7c..f4ddc412 100644 --- a/src/opam_file.ml +++ b/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 diff --git a/src/sexp_lexer.mli b/src/sexp_lexer.mli index 293adc4e..1214c711 100644 --- a/src/sexp_lexer.mli +++ b/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 diff --git a/src/sexp_lexer.mll b/src/sexp_lexer.mll index d9273da8..adb067ee 100644 --- a/src/sexp_lexer.mll +++ b/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 } diff --git a/src/sexp_load.ml b/src/sexp_load.ml deleted file mode 100644 index 1925e2d8..00000000 --- a/src/sexp_load.ml +++ /dev/null @@ -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 diff --git a/src/sexp_load.mli b/src/sexp_load.mli deleted file mode 100644 index 707a8135..00000000 --- a/src/sexp_load.mli +++ /dev/null @@ -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 diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml index 3a3092c3..bfc1b594 100644 --- a/src/vfile_kind.ml +++ b/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 diff --git a/src/watermarks.ml b/src/watermarks.ml index 36c9f908..b8a8127b 100644 --- a/src/watermarks.ml +++ b/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 = diff --git a/src/workspace.ml b/src/workspace.ml index 667b68b5..ddd8a19c 100644 --- a/src/workspace.ml +++ b/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)