diff --git a/.ocamlformat b/.ocamlformat index 2ea44df..47d2960 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.24.1 +version = 0.27.0 profile=conventional margin=80 if-then-else=k-r diff --git a/benchpress.opam b/benchpress.opam index dac74a4..442d7da 100644 --- a/benchpress.opam +++ b/benchpress.opam @@ -17,6 +17,7 @@ depends: [ "re" { >= "1.8" & < "2.0" } "csv" "cmdliner" {>= "1.1.0"} + "ppx_subliner" "iter" { >= "1.0" } # TODO: remove "logs" "uuidm" diff --git a/src/bin/benchpress_bin.ml b/src/bin/benchpress_bin.ml index f4f3102..c38791b 100644 --- a/src/bin/benchpress_bin.ml +++ b/src/bin/benchpress_bin.ml @@ -16,315 +16,195 @@ let catch_err f = (** {2 Run} *) module Run = struct - (* sub-command for running tests *) - let cmd = + (* Custom CPU spec parser - kept separate due to complex logic *) + let cpus_term = let open Cmdliner in - let aux j cpus pp_results dyn paths dir_files proof_dir (log_lvl, defs) task - timeout memory meta provers csv summary no_color output save wal_mode - desktop_notification no_failure update = - Misc.setup_logs log_lvl; - catch_err @@ fun () -> - if no_color then CCFormat.set_color_default false; - let dyn = - if dyn then - Some true - else - None - in - Run_main.main ~pp_results ?dyn ~j ?cpus ?timeout ?memory ?csv ~provers - ~meta ?task ?summary ~dir_files ?proof_dir ?output ~save ~wal_mode - ~desktop_notification ~no_failure ~update defs paths () + let doc = + "Limit the specific CPUs or cores to use. When provided, the\n\ + \ [-j] flag is ignored, and each prover gets allocated its own CPU \ + core from\n\ + \ this list. A comma-separated list or hyphen-separated ranges are \ + allowed." in - let defs = Bin_utils.definitions_term - and dyn = Arg.(value & flag & info [ "progress" ] ~doc:"print progress bar") - and pp_results = - Arg.( - value & opt bool true - & info [ "pp-results" ] ~doc:"print results as they are found") - and output = - Arg.( - value - & opt (some string) None - & info [ "o"; "output" ] ~doc:"output database file") - and save = - Arg.(value & opt bool true & info [ "save" ] ~doc:"save results on disk") - and wal_mode = - Arg.(value & flag & info [ "wal" ] ~doc:"turn on the journal WAL mode") - and dir_files = - Arg.( - value & opt_all file [] - & info [ "F" ] ~doc:"file containing a list of files") - and proof_dir = - Arg.( - value - & opt (some string) None - & info [ "proof-dir" ] ~doc:"store proofs in given directory") - and task = - Arg.(value & opt (some string) None & info [ "task" ] ~doc:"task to run") - and timeout = - Arg.( - value - & opt (some int) None - & info [ "t"; "timeout" ] ~doc:"timeout (in s)") - and j = Arg.(value & opt int 1 & info [ "j" ] ~doc:"level of parallelism") - and cpus = - let doc = - "Limit the specific CPUs or cores to use. When provided, the\n\ - \ [-j] flag is ignored, and each prover gets allocated its own \ - CPU core from\n\ - \ this list. A comma-separated list or hyphen-separated ranges \ - are allowed." - in - let parser s = - match String.split_on_char '-' s with - | [] -> assert false (* [split_on_char] invariant *) - | [ n ] -> Result.map (fun x -> x, x) Arg.(conv_parser int n) - | [ n; m ] -> - Result.bind Arg.(conv_parser int n) @@ fun n -> - Result.bind Arg.(conv_parser int m) @@ fun m -> - if m < n then - Error (`Msg (Format.asprintf "invalid range: %d-%d" n m)) - else - Ok (n, m) - | _ -> Error (`Msg (Format.asprintf "invalid cpuset: %s" s)) - in - let printer ppf (n, m) = - if n = m then - Format.pp_print_int ppf n + let parser s = + match String.split_on_char '-' s with + | [] -> assert false (* [split_on_char] invariant *) + | [ n ] -> Result.map (fun x -> x, x) Arg.(conv_parser int n) + | [ n; m ] -> + Result.bind Arg.(conv_parser int n) @@ fun n -> + Result.bind Arg.(conv_parser int m) @@ fun m -> + if m < n then + Error (`Msg (Format.asprintf "invalid range: %d-%d" n m)) else - Format.fprintf ppf "%d-%d" n m - in - let cpuspec = Arg.conv ~docv:"MASK" (parser, printer) in - let parse xs = - let cpus = - CCList.flat_map - (fun (n, m) -> List.init (m + 1 - n) (fun i -> i + n)) - xs - |> List.sort_uniq Int.compare - in - match cpus with - | [] -> None - | _ -> Some cpus + Ok (n, m) + | _ -> Error (`Msg (Format.asprintf "invalid cpuset: %s" s)) + in + let printer ppf (n, m) = + if n = m then + Format.pp_print_int ppf n + else + Format.fprintf ppf "%d-%d" n m + in + let cpuspec = Arg.conv ~docv:"MASK" (parser, printer) in + let parse xs = + let cpus = + CCList.flat_map + (fun (n, m) -> List.init (m + 1 - n) (fun i -> i + n)) + xs + |> List.sort_uniq Int.compare in - Term.( - const parse $ Arg.(value & opt (list cpuspec) [] & info [ "cpus" ] ~doc)) - and memory = - Arg.( - value - & opt (some int) None - & info [ "m"; "memory" ] ~doc:"memory (in MB)") - and meta = - Arg.( - value & opt string "" - & info [ "meta" ] ~doc:"additional metadata to save") - and doc = + match cpus with + | [] -> None + | _ -> Some cpus + in + Term.( + const parse $ Arg.(value & opt (list cpuspec) [] & info [ "cpus" ] ~doc)) + + (* Parameters using ppx_subliner *) + type params = { + j: int; [@default 1] (** level of parallelism *) + progress: bool; (** print progress bar *) + pp_results: bool; [@default true] (** print results as they are found *) + paths: string list; [@pos_all] [@docv "PATH"] + (** target paths (or directories containing tests) *) + dir_files: string list; [@opt_all] [@names [ "F" ]] [@default []] + (** file containing a list of files *) + proof_dir: string option; (** store proofs in given directory *) + task: string option; (** task to run *) + timeout: int option; [@names [ "t"; "timeout" ]] (** timeout (in s) *) + memory: int option; [@names [ "m"; "memory" ]] (** memory (in MB) *) + meta: string; [@default ""] (** additional metadata to save *) + provers: string list; [@opt_all] [@names [ "p"; "provers" ]] [@default []] + (** select provers *) + csv: string option; (** CSV output file *) + summary: string option; (** write summary in FILE *) + no_color: bool; [@names [ "no-color"; "nc" ]] (** disable colored output *) + output: string option; [@names [ "o"; "output" ]] + (** output database file *) + save: bool; [@default true] (** save results on disk *) + wal_mode: bool; [@names [ "wal" ]] (** turn on the journal WAL mode *) + desktop_notification: bool; + [@default true] [@names [ "desktop-notification"; "dn" ]] + (** send a desktop notification when the benchmarking is done (true by + default) *) + no_failure: bool; [@names [ "no-failure"; "nf" ]] + (** don't fail if some provers give incorrect answers (contradictory to + what was expected) *) + update: bool; [@names [ "update"; "u" ]] + (** if the output file already exists, overwrite it with the new one. *) + } + [@@deriving subliner] + + let run (p : params) cpus (log_lvl, defs) = + Misc.setup_logs log_lvl; + catch_err @@ fun () -> + if p.no_color then CCFormat.set_color_default false; + let dyn = + if p.progress then + Some true + else + None + in + Run_main.main ~pp_results:p.pp_results ?dyn ~j:p.j ?cpus ?timeout:p.timeout + ?memory:p.memory ?csv:p.csv ~provers:p.provers ~meta:p.meta ?task:p.task + ?summary:p.summary ~dir_files:p.dir_files ?proof_dir:p.proof_dir + ?output:p.output ~save:p.save ~wal_mode:p.wal_mode + ~desktop_notification:p.desktop_notification ~no_failure:p.no_failure + ~update:p.update defs p.paths () + + let cmd = + let doc = "run a task, such as running solvers on directories of problem files" - and csv = - Arg.( - value & opt (some string) None & info [ "csv" ] ~doc:"CSV output file") - and paths = - Arg.( - value & pos_all string [] - & info [] ~docv:"PATH" - ~doc:"target paths (or directories containing tests)") - and provers = - Arg.( - value & opt_all string [] - & info [ "p"; "provers" ] ~doc:"select provers") - and no_color = - Arg.( - value & flag & info [ "no-color"; "nc" ] ~doc:"disable colored output") - and summary = - Arg.( - value - & opt (some string) None - & info [ "summary" ] ~doc:"write summary in FILE") - and desktop_notification = - Arg.( - value & opt bool true - & info - [ "desktop-notification"; "dn" ] - ~doc: - "send a desktop notification when the benchmarking is done (true \ - by default)") - and no_failure = - Arg.( - value & flag - & info [ "no-failure"; "nf" ] - ~doc: - "don't fail if some provers give incorrect answers \ - (contradictory to what was expected)") - and update = - Arg.( - value & flag - & info [ "update"; "u" ] - ~doc: - "if the output file already exists, overwrite it with the new \ - one.") in - Cmd.v (Cmd.info ~doc "run") - Term.( - const aux $ j $ cpus $ pp_results $ dyn $ paths $ dir_files $ proof_dir - $ defs $ task $ timeout $ memory $ meta $ provers $ csv $ summary - $ no_color $ output $ save $ wal_mode $ desktop_notification - $ no_failure $ update) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "run") + Cmdliner.Term.( + const run $ params_cmdliner_term () $ cpus_term + $ Bin_utils.definitions_term) end module Slurm = struct (* sub-command for running tests with slurm *) - let cmd = - let open Cmdliner in - let aux j pp_results dyn paths dir_files proof_dir (log_lvl, defs) task - timeout memory meta provers csv summary no_color output save wal_mode - desktop_notification no_failure update partition nodes addr port ntasks - = - Misc.setup_logs log_lvl; - catch_err @@ fun () -> - if no_color then CCFormat.set_color_default false; - let dyn = - if dyn then - Some true - else - None - in - Run_main.main ~sbatch:true ~pp_results ?dyn ~j ?timeout ?memory ?csv - ~provers ~meta ?task ?summary ~dir_files ?proof_dir ?output ~wal_mode - ~desktop_notification ~no_failure ~update ~save ?partition ?nodes ?addr - ?port ?ntasks defs paths () + type params = { + j: int; [@default 1] + (** number of parallel threads each worker will launch on the node on + which it's running. *) + progress: bool; (** print progress bar *) + pp_results: bool; [@default true] (** print results as they are found *) + paths: string list; [@pos_all] [@docv "PATH"] + (** target paths (or directories containing tests) *) + dir_files: string list; [@opt_all] [@names [ "F" ]] [@default []] + (** file containing a list of files *) + proof_dir: string option; (** store proofs in given directory *) + task: string option; (** task to run *) + timeout: int option; [@names [ "t"; "timeout" ]] (** timeout (in s) *) + memory: int option; [@names [ "m"; "memory" ]] (** memory (in MB) *) + meta: string; [@default ""] (** additional metadata to save *) + provers: string list; [@opt_all] [@names [ "p"; "provers" ]] [@default []] + (** select provers *) + csv: string option; (** CSV output file *) + summary: string option; (** write summary in FILE *) + no_color: bool; [@names [ "no-color"; "nc" ]] (** disable colored output *) + output: string option; [@names [ "o"; "output" ]] + (** output database file *) + save: bool; [@default true] (** save results on disk *) + wal_mode: bool; [@names [ "wal" ]] (** turn on the journal WAL mode *) + desktop_notification: bool; + [@default true] [@names [ "desktop-notification"; "dn" ]] + (** send a desktop notification when the benchmarking is done (true by + default) *) + no_failure: bool; [@names [ "no-failure"; "nf" ]] + (** don't fail if some provers give incorrect answers (contradictory to + what was expected) *) + update: bool; [@names [ "update"; "u" ]] + (** if the output file already exists, overwrite it with the new one. *) + partition: string option; + (** partition to which the allocated nodes should belong *) + nodes: int option; [@names [ "n"; "nodes" ]] + (** the maximum number of nodes to be used *) + addr: string option; [@names [ "a"; "addr" ]] + (** IP address of the server on the control node. Needs to be reachable + by the workers which will run on the allocated calculation nodes. *) + port: int option; + (** port of the server on the control node. Default is 0 to let the OS + choose a port. *) + ntasks: int option; + (** The number of tasks to give the workers at a time. *) + } + [@@deriving subliner] + + let run (p : params) (log_lvl, defs) = + Misc.setup_logs log_lvl; + catch_err @@ fun () -> + if p.no_color then CCFormat.set_color_default false; + let dyn = + if p.progress then + Some true + else + None in - let defs = Bin_utils.definitions_term - and doc = + let addr = + match p.addr with + | None -> None + | Some s -> Some (Unix.inet_addr_of_string s) + in + Run_main.main ~sbatch:true ~pp_results:p.pp_results ?dyn ~j:p.j + ?timeout:p.timeout ?memory:p.memory ?csv:p.csv ~provers:p.provers + ~meta:p.meta ?task:p.task ?summary:p.summary ~dir_files:p.dir_files + ?proof_dir:p.proof_dir ?output:p.output ~wal_mode:p.wal_mode + ~desktop_notification:p.desktop_notification ~no_failure:p.no_failure + ~update:p.update ~save:p.save ?partition:p.partition ?nodes:p.nodes ?addr + ?port:p.port ?ntasks:p.ntasks defs p.paths () + + let cmd = + let doc = "run benchpress using the computing power of a cluster that works with \ slurm" - and dyn = Arg.(value & flag & info [ "progress" ] ~doc:"print progress bar") - and pp_results = - Arg.( - value & opt bool true - & info [ "pp-results" ] ~doc:"print results as they are found") - and output = - Arg.( - value - & opt (some string) None - & info [ "o"; "output" ] ~doc:"output database file") - and save = - Arg.(value & opt bool true & info [ "save" ] ~doc:"save results on disk") - and wal_mode = - Arg.(value & flag & info [ "wal" ] ~doc:"turn on the journal WAL mode") - and dir_files = - Arg.( - value & opt_all file [] - & info [ "F" ] ~doc:"file containing a list of files") - and proof_dir = - Arg.( - value - & opt (some string) None - & info [ "proof-dir" ] ~doc:"store proofs in given directory") - and task = - Arg.(value & opt (some string) None & info [ "task" ] ~doc:"task to run") - and timeout = - Arg.( - value - & opt (some int) None - & info [ "t"; "timeout" ] ~doc:"timeout (in s)") - and j = - Arg.( - value & opt int 1 - & info [ "j" ] - ~doc: - "number of parallel threads each worker will launch on the node \ - on which it's running.") - and memory = - Arg.( - value - & opt (some int) None - & info [ "m"; "memory" ] ~doc:"memory (in MB)") - and meta = - Arg.( - value & opt string "" - & info [ "meta" ] ~doc:"additional metadata to save") - and csv = - Arg.( - value & opt (some string) None & info [ "csv" ] ~doc:"CSV output file") - and paths = - Arg.( - value & pos_all string [] - & info [] ~docv:"PATH" - ~doc:"target paths (or directories containing tests)") - and provers = - Arg.( - value & opt_all string [] - & info [ "p"; "provers" ] ~doc:"select provers") - and no_color = - Arg.( - value & flag & info [ "no-color"; "nc" ] ~doc:"disable colored output") - and summary = - Arg.( - value - & opt (some string) None - & info [ "summary" ] ~doc:"write summary in FILE") - and partition = - Arg.( - value - & opt (some string) None - & info [ "partition" ] - ~doc:"partition to which the allocated nodes should belong") - and nodes = - Arg.( - value - & opt (some int) None - & info [ "n"; "nodes" ] ~doc:"the maximum number of nodes to be used") - and addr = - Arg.( - value - & opt (some Misc.ip_addr_conv) None - & info [ "a"; "addr" ] - ~doc: - "IP address of the server on the control node. Needs to be \ - reachable by the workers which will run on the allocated \ - calculation nodes.") - and port = - Arg.( - value - & opt (some int) None - & info [ "port" ] - ~doc: - "port of the server on the control node. Default is 0 to let the \ - OS choose a port.") - and ntasks = - Arg.( - value - & opt (some int) None - & info [ "ntasks" ] - ~doc:"The number of tasks to give the workers at a time.") - and desktop_notification = - Arg.( - value & opt bool true - & info - [ "desktop-notification"; "dn" ] - ~doc: - "send a desktop notification when the benchmarking is done (true \ - by default)") - and no_failure = - Arg.( - value & flag - & info [ "no-failure"; "nf" ] - ~doc: - "don't fail if some provers give incorrect answers \ - (contradictory to what was expected)") - and update = - Arg.( - value & flag - & info [ "update"; "u" ] - ~doc: - "if the output file already exists, overwrite it with the new \ - one.") in - Cmd.v (Cmd.info ~doc "slurm") - Term.( - const aux $ j $ pp_results $ dyn $ paths $ dir_files $ proof_dir $ defs - $ task $ timeout $ memory $ meta $ provers $ csv $ summary $ no_color - $ output $ save $ wal_mode $ desktop_notification $ no_failure $ update - $ partition $ nodes $ addr $ port $ ntasks) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "slurm") + Cmdliner.Term.( + const run $ params_cmdliner_term () $ Bin_utils.definitions_term) end module List_files = struct @@ -344,61 +224,41 @@ module List_files = struct entries; () - (* sub-command to sample a directory *) + type params = { abs: bool [@default false] (** show absolute paths *) } + [@@deriving subliner] + let cmd = - let open Cmdliner in - let abs = - Arg.( - value & opt ~vopt:true bool false - & info [ "abs" ] ~doc:"show absolute paths") - in let doc = "list benchmark result files" in - let aux abs () = main ~abs () in - Cmd.v (Cmd.info ~doc "list-files") Term.(const aux $ abs $ const ()) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "list-files") + Cmdliner.Term.( + const (fun p -> main ~abs:p.abs ()) $ params_cmdliner_term ()) end module Show = struct - (* sub-command for showing results *) + type params = { + csv: string option; (** CSV output file *) + file: string; [@pos 0] [@docv "FILE"] (** file to read *) + no_color: bool; [@names [ "no-color"; "nc" ]] (** disable colored output *) + check: bool; [@default true] (** check results *) + bad: bool; [@default true] (** list bad results *) + summary: string option; (** write summary in FILE *) + details: bool; (** show more details *) + } + [@@deriving subliner] + + let run (p : params) debug = + catch_err @@ fun () -> + Misc.setup_logs debug; + if p.no_color then CCFormat.set_color_default false; + Show.main ~check:p.check ~bad:p.bad ~details:p.details ?csv:p.csv + ?summary:p.summary p.file + let cmd = - let open Cmdliner in - let csv = - Arg.( - value & opt (some string) None & info [ "csv" ] ~doc:"CSV output file") - and file = - Arg.( - required - & pos 0 (some string) None - & info [] ~docv:"FILE" ~doc:"file to read") - and no_color = - Arg.( - value & flag & info [ "no-color"; "nc" ] ~doc:"disable colored output") - and check = - Arg.( - value & opt ~vopt:true bool true & info [ "check" ] ~doc:"check results") - and bad = - Arg.( - value & opt ~vopt:true bool true - & info [ "bad" ] ~doc:"list bad results") - and summary = - Arg.( - value - & opt (some string) None - & info [ "summary" ] ~doc:"write summary in FILE") - and debug = Logs_cli.level () - and details = - Arg.(value & flag & info [ "details" ] ~doc:"show more details") - in - let aux check bad csv summary no_color debug details file : bool = - catch_err @@ fun () -> - Misc.setup_logs debug; - if no_color then CCFormat.set_color_default false; - Show.main ~check ~bad ~details ?csv ?summary file - in let doc = "show benchmark results (see `list-files`)" in - Cmd.v (Cmd.info ~doc "show") - Term.( - const aux $ check $ bad $ csv $ summary $ no_color $ debug $ details - $ file) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "show") + Cmdliner.Term.(const run $ params_cmdliner_term () $ Logs_cli.level ()) end (** {2 plot results} *) @@ -412,22 +272,19 @@ module Plot = struct Cactus_plot.show p; ()) - (* sub-command for showing results *) + type params = { file: string [@pos 0] [@docv "FILE"] (** file to read *) } + [@@deriving subliner] + + let run (p : params) debug = + catch_err @@ fun () -> + Misc.setup_logs debug; + main p.file + let cmd = - let open Cmdliner in - let file = - Arg.( - required - & pos 0 (some string) None - & info [] ~docv:"FILE" ~doc:"file to read") - and debug = Logs_cli.level () in - let aux debug file = - catch_err @@ fun () -> - Misc.setup_logs debug; - main file - in let doc = "plot benchmark results" in - Cmd.v (Cmd.info ~doc "plot") Term.(const aux $ debug $ file) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "plot") + Cmdliner.Term.(const run $ params_cmdliner_term () $ Logs_cli.level ()) end (** {2 Sample} *) @@ -455,28 +312,25 @@ module Sample = struct Misc.synchronized (fun () -> List.iter (Printf.printf "%s\n%!") sample); () - (* sub-command to sample a directory *) + type params = { + dirs: string list; [@pos_all] [@docv "DIR"] + (** target directories (containing tests) *) + n: int; [@default 1] [@docv "N"] (** number of files to sample *) + } + [@@deriving subliner] + let cmd = - let open Cmdliner in - let aux n dir = run ~n dir in - let dir = - Arg.( - value & pos_all string [] - & info [] ~docv:"DIR" ~doc:"target directories (containing tests)") - and n = - Arg.( - value & opt int 1 - & info [ "n" ] ~docv:"N" ~doc:"number of files to sample") - and doc = "sample N files in the given directories" in - Cmd.v (Cmd.info ~doc "sample") Term.(const aux $ n $ dir) + let doc = "sample N files in the given directories" in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "sample") + Cmdliner.Term.( + const (fun p -> run ~n:p.n p.dirs) $ params_cmdliner_term ()) end (** {2 Show directories} *) module Dir = struct - type which = Config | State - - let which_conv = Cmdliner.Arg.(enum [ "config", Config; "state", State ]) + type which = Config | State [@@deriving subliner_enum] let run c = catch_err @@ fun () -> @@ -486,14 +340,10 @@ module Dir = struct | State -> Misc.data_dir ()); () - (* sub-command for showing results *) let cmd = let open Cmdliner in let which = - Arg.( - required - & pos 0 (some which_conv) None - & info ~doc:"directory to list (config|state)" []) + Arg.(required & pos 0 (some (which_cmdliner_conv ())) None & info []) in let doc = "show directories where benchpress stores its state (config|state)" @@ -504,20 +354,27 @@ end (** {2 Check config} *) module Check_config = struct - let run debug with_default f = + type params = { + files: string list; [@pos_all] [@default []] (** file(s) to check *) + with_default: bool; [@default false] [@names [ "d"; "default" ]] + (** combine with the default config file(s) *) + } + [@@deriving subliner] + + let run (p : params) debug = catch_err @@ fun () -> Misc.setup_logs debug; let default_file = Misc.default_config () in let f = - if f = [] then + if p.files = [] then if Sys.file_exists default_file then [ default_file ] else [] - else if with_default && Sys.file_exists default_file then - Misc.default_config () :: f + else if p.with_default && Sys.file_exists default_file then + Misc.default_config () :: p.files else - f + p.files in let l = Stanza.parse_files f in Format.printf "@[%a@]@." Stanza.pp_l l; @@ -526,39 +383,31 @@ module Check_config = struct () let cmd = - let open Cmdliner in - let files = - Arg.(value & pos_all string [] & info [] ~doc:"file(s) to check") - and debug = Logs_cli.level () - and with_default = - Arg.( - value & opt bool false - & info [ "d"; "default" ] ~doc:"combine with the default config file(s)") - in let doc = "parse and print configuration file(s)" in - let aux debug with_default files () = run debug with_default files in - Cmd.v - (Cmd.info ~doc "check-config") - Term.(const aux $ debug $ with_default $ files $ const ()) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "check-config") + Cmdliner.Term.(const run $ params_cmdliner_term () $ Logs_cli.level ()) end (** {2 See prover(s)} *) module Prover_show = struct - let run (log_lvl, defs) names = + type params = { names: string list [@pos_all] [@default []] } + [@@deriving subliner] + + let run (p : params) (log_lvl, defs) = Misc.setup_logs log_lvl; catch_err @@ fun () -> - let l = CCList.map (Definitions.find_prover' defs) names in + let l = CCList.map (Definitions.find_prover' defs) p.names in Format.printf "@[%a@]@." (Misc.pp_list Prover.pp) l; () let cmd = - let open Cmdliner in let doc = "show definitions of given prover(s)" in - let names = Arg.(value & pos_all string [] & info []) in - Cmd.v - (Cmd.info ~doc "show-prover") - Term.(const run $ Bin_utils.definitions_term $ names) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "show-prover") + Cmdliner.Term.( + const run $ params_cmdliner_term () $ Bin_utils.definitions_term) end (** {2 List provers} *) @@ -574,30 +423,31 @@ module Prover_list = struct () let cmd = - let open Cmdliner in let doc = "list prover(s) defined in config" in - Cmd.v - (Cmd.info ~doc "list-prover") - Term.(const run $ Bin_utils.definitions_term) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "list-prover") + Cmdliner.Term.(const run $ Bin_utils.definitions_term) end (** {2 Show Task} *) module Task_show = struct - let run (log_lvl, defs) names = + type params = { names: string list [@pos_all] [@default []] } + [@@deriving subliner] + + let run (p : params) (log_lvl, defs) = Misc.setup_logs log_lvl; catch_err @@ fun () -> - let l = CCList.map (Definitions.find_task' defs) names in + let l = CCList.map (Definitions.find_task' defs) p.names in Format.printf "@[%a@]@." (Misc.pp_list Task.pp) l; () let cmd = - let open Cmdliner in let doc = "show definitions of given task(s)" in - let names = Arg.(value & pos_all string [] & info []) in - Cmd.v - (Cmd.info ~doc "show-task") - Term.(const run $ Bin_utils.definitions_term $ names) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "show-task") + Cmdliner.Term.( + const run $ params_cmdliner_term () $ Bin_utils.definitions_term) end (** {2 List Tasks} *) @@ -613,30 +463,29 @@ module Task_list = struct () let cmd = - let open Cmdliner in let doc = "list task(s) defined in config" in - Cmd.v - (Cmd.info ~doc "list-task") - Term.(const run $ Bin_utils.definitions_term) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "list-task") + Cmdliner.Term.(const run $ Bin_utils.definitions_term) end (** {2 Convert results to Sql} *) module Sql_convert = struct - let run defs files = catch_err @@ fun () -> Sql_res.run defs files + type params = { + files: string list; [@pos_all] [@non_empty] [@docv "FILES"] + (** files to read *) + } + [@@deriving subliner] + + let run (p : params) defs = catch_err @@ fun () -> Sql_res.run defs p.files - (* sub-command for showing results *) let cmd = - let open Cmdliner in - let files = - Arg.( - non_empty & pos_all string [] - & info [] ~docv:"FILES" ~doc:"files to read") - in let doc = "convert result(s) into sqlite files" in - Cmd.v - (Cmd.info ~doc "sql-convert") - Term.(const run $ Bin_utils.definitions_term $ files) + Cmdliner.Cmd.v + (Cmdliner.Cmd.info ~doc "sql-convert") + Cmdliner.Term.( + const run $ params_cmdliner_term () $ Bin_utils.definitions_term) end (** {2 Main: Parse CLI} *) diff --git a/src/bin/dune b/src/bin/dune index ee95fce..889ca88 100644 --- a/src/bin/dune +++ b/src/bin/dune @@ -8,6 +8,8 @@ (until-clean)) (libraries benchpress containers cmdliner uuidm logs logs.cli sqlite3_utils base64) + (preprocess + (pps ppx_subliner)) (flags :standard -warn-error -a+8 -safe-string -open Benchpress)) (rule diff --git a/src/core/Cactus_plot.ml b/src/core/Cactus_plot.ml index 40e52b8..353aace 100644 --- a/src/core/Cactus_plot.ml +++ b/src/core/Cactus_plot.ml @@ -29,9 +29,9 @@ let of_db ?provers db = ) order by rtime|} (if has_custom_tags then - "or exists (select 1 from custom_tags where tag=res)" - else - "")) + "or exists (select 1 from custom_tags where tag=res)" + else + "")) prover ~ty:Db.Ty.(p1 text, p1 float, id) ~f:Db.Cursor.to_list diff --git a/src/core/Definitions.mli b/src/core/Definitions.mli index a097804..5b3d887 100644 --- a/src/core/Definitions.mli +++ b/src/core/Definitions.mli @@ -54,10 +54,9 @@ val mk_run_provers : loc:Loc.t option -> t -> Action.run_provers -(** Build a "run" action from the given prover names - and directory paths. - All the provers must be defined, and the paths must be contained - in declared [dir]. *) +(** Build a "run" action from the given prover names and directory paths. All + the provers must be defined, and the paths must be contained in declared + [dir]. *) val mk_run_provers_slurm_submission : ?j:int -> diff --git a/src/core/Error.mli b/src/core/Error.mli index 3bd39c5..31d156f 100644 --- a/src/core/Error.mli +++ b/src/core/Error.mli @@ -32,11 +32,9 @@ val fail : ?loc:Loc.t -> string -> 'a val failf : ?loc:Loc.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a val guard : (t -> t) -> (unit -> 'a) -> 'a -(** [guard wrap f] runs [f()], and wraps the error with [wrap] if - it fails. +(** [guard wrap f] runs [f()], and wraps the error with [wrap] if it fails. - Typical usage: [Error.guard (Error.wrapf "oh no %d" 42) @@ fun () -> …] -*) + Typical usage: [Error.guard (Error.wrapf "oh no %d" 42) @@ fun () -> …] *) val pp : t Fmt.printer val show : t -> string diff --git a/src/core/Exec_action.ml b/src/core/Exec_action.ml index 3532999..fb76711 100644 --- a/src/core/Exec_action.ml +++ b/src/core/Exec_action.ml @@ -47,11 +47,10 @@ module Exec_run_provers : sig wal_mode:bool -> expanded -> Test_top_result.t lazy_t * Test_compact_result.t - (** Run the given prover(s) on the given problem set, obtaining results - after all the problems have been dealt with. - @param on_solve called whenever a single problem is solved - @param on_done called when the whole process is done - *) + (** Run the given prover(s) on the given problem set, obtaining results after + all the problems have been dealt with. + @param on_solve called whenever a single problem is solved + @param on_done called when the whole process is done *) val run_sbatch_job : ?timestamp:float -> @@ -574,7 +573,8 @@ end = struct in let sock, used_port = Misc.mk_socket (Unix.ADDR_INET (addr, port)) in - ignore (Thread.create (fun () -> Misc.start_server nodes server_loop sock) ()); + ignore + (Thread.create (fun () -> Misc.start_server nodes server_loop sock) ()); Log.debug (fun k -> k "Spawned the thread that establishes a server listening at: %s:%s." @@ -676,8 +676,8 @@ module Progress_run_provers : sig (** Make a progress tracker. @param dyn if true, print a progress bar in the terminal @param pp_results if true, print each individual result as it's found - @param on_progress callback when progress is made, with a percentage and ETA - *) + @param on_progress + callback when progress is made, with a percentage and ETA *) end = struct type t = < on_res : Run_prover_problem.job_res -> unit diff --git a/src/core/Exec_action.mli b/src/core/Exec_action.mli index b8bbef1..985fefe 100644 --- a/src/core/Exec_action.mli +++ b/src/core/Exec_action.mli @@ -50,11 +50,10 @@ module Exec_run_provers : sig wal_mode:bool -> expanded -> Test_top_result.t lazy_t * Test_compact_result.t - (** Run the given prover(s) on the given problem set, obtaining results - after all the problems have been dealt with. - @param on_solve called whenever a single problem is solved - @param on_done called when the whole process is done - *) + (** Run the given prover(s) on the given problem set, obtaining results after + all the problems have been dealt with. + @param on_solve called whenever a single problem is solved + @param on_done called when the whole process is done *) val run_sbatch_job : ?timestamp:float -> @@ -96,8 +95,8 @@ module Progress_run_provers : sig (** Make a progress tracker. @param dyn if true, print a progress bar in the terminal @param pp_results if true, print each individual result as it's found - @param on_progress callback when progress is made, with a percentage and ETA - *) + @param on_progress + callback when progress is made, with a percentage and ETA *) end val dump_results_sqlite : Test_top_result.t -> unit diff --git a/src/core/Limit.mli b/src/core/Limit.mli index ec04ee8..7c642d1 100644 --- a/src/core/Limit.mli +++ b/src/core/Limit.mli @@ -18,8 +18,8 @@ module Time : sig (** Printer *) val mk : ?s:int -> ?m:int -> ?h:int -> unit -> t - (** Create a timeout of [~h] hours, [~m] minutes and - [~s] seconds. The arguments default to [0] is not provided. *) + (** Create a timeout of [~h] hours, [~m] minutes and [~s] seconds. The + arguments default to [0] is not provided. *) val default : t @@ -27,12 +27,12 @@ module Time : sig (** Add timeouts. *) val as_int : view -> t -> int - (** View a time converted into the given view/units, truncating - the result. For instance: [as_int Minutes (mk ~s:90) = 1] *) + (** View a time converted into the given view/units, truncating the result. + For instance: [as_int Minutes (mk ~s:90) = 1] *) val as_float : view -> t -> float - (** View a time converted into the given view/units. - For instance: [as_float Minutes (mk ~s:90) = 1.5] *) + (** View a time converted into the given view/units. For instance: + [as_float Minutes (mk ~s:90) = 1.5] *) end (** {1 Memory limits} *) @@ -53,19 +53,19 @@ module Memory : sig (** Printer *) val mk : ?b:int -> ?k:int -> ?m:int -> ?g:int -> ?t:int -> unit -> t - (** Create a memory limits of [~t] terabytes, [~g] gigabytes, - [~m] megabytes, [~k] kilobytes, and [~b] bytes. The arguments default - to [0] if not provided. *) + (** Create a memory limits of [~t] terabytes, [~g] gigabytes, [~m] megabytes, + [~k] kilobytes, and [~b] bytes. The arguments default to [0] if not + provided. *) val default : t val as_int : view -> t -> int - (** View a memory size converted into the given view/units, truncating - the result. For instance: [as_int Kilobytes (mk ~b:1_500) = 1] *) + (** View a memory size converted into the given view/units, truncating the + result. For instance: [as_int Kilobytes (mk ~b:1_500) = 1] *) val as_float : view -> t -> float - (** View a memory size converted into the given view/units. - For instance: [as_float Kilobytes (mk ~b:1_500) = 1.5] *) + (** View a memory size converted into the given view/units. For instance: + [as_float Kilobytes (mk ~b:1_500) = 1.5] *) end (** {1 Stack limits} *) @@ -90,8 +90,8 @@ module All : sig memory: Memory.t option; stack: Stack.t option; } - (** Type used to represent a set of (optional) limits, - including a time limit, a memory limit and a stack limit. *) + (** Type used to represent a set of (optional) limits, including a time limit, + a memory limit and a stack limit. *) val hash : t -> int val equal : t -> t -> bool @@ -113,13 +113,13 @@ module All : sig (** Update functions *) val with_defaults : defaults:t -> t -> t - (** [with_defaults ~defaults t] is the same as t, except for limits - of [t] which were [None], in which case the value from [defaults] - is used (which can itself also be [None]). *) + (** [with_defaults ~defaults t] is the same as t, except for limits of [t] + which were [None], in which case the value from [defaults] is used (which + can itself also be [None]). *) exception Limit_missing of string - (** Exception raised by {!substitute} when trying to substitute a - limit that was not provided. *) + (** Exception raised by {!substitute} when trying to substitute a limit that + was not provided. *) val substitute : time_as:Time.view -> @@ -128,9 +128,9 @@ module All : sig t -> string -> string option - (** Given a set of limits, and a view for each of these limits, - return a substitution function adequate for use with - {!Buffer.add_substitute}. - @raise Limit_missing if a limit is needed for substitution - but not present in the argument. *) + (** Given a set of limits, and a view for each of these limits, return a + substitution function adequate for use with {!Buffer.add_substitute}. + @raise Limit_missing + if a limit is needed for substitution but not present in the argument. + *) end diff --git a/src/core/Misc.ml b/src/core/Misc.ml index f2a79c7..0039a15 100644 --- a/src/core/Misc.ml +++ b/src/core/Misc.ml @@ -165,11 +165,11 @@ let human_duration (f : float) : string = print_aux "d" n_day ^ print_aux "h" n_hour ^ print_aux "m" n_min ^ string_of_int n ^ (if f -. floor f >= 0.1 then ( - let s = Printf.sprintf "%.1f" (f -. floor f) in - "." ^ snd @@ CCString.Split.left_exn ~by:"." s - (* remove the leading "0." *) - ) else - "") + let s = Printf.sprintf "%.1f" (f -. floor f) in + "." ^ snd @@ CCString.Split.left_exn ~by:"." s + (* remove the leading "0." *) + ) else + "") ^ "s" ) else Printf.sprintf "%.3fs" f @@ -308,12 +308,15 @@ module Par_map = struct let pool = Moonpool.Fifo_pool.create ~num_threads:j () in let res = try - let futs = List.map (fun x -> Moonpool.Fut.spawn ~on:pool (fun () -> f x)) l in + let futs = + List.map (fun x -> Moonpool.Fut.spawn ~on:pool (fun () -> f x)) l + in let results = List.map Moonpool.Fut.wait_block futs in - List.map (function - | Ok x -> x - | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt - ) results + List.map + (function + | Ok x -> x + | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt) + results with e -> Logs.debug (fun k -> k "par-map: shutdown pool (exception)"); Moonpool.Fifo_pool.shutdown pool; @@ -346,15 +349,19 @@ module Par_map = struct let pool = Moonpool.Fifo_pool.create ~num_threads:jobs () in let res = try - let futs = List.map (fun x -> - Moonpool.Fut.spawn ~on:pool (fun () -> f_with_resource x) - ) l in + let futs = + List.map + (fun x -> + Moonpool.Fut.spawn ~on:pool (fun () -> f_with_resource x)) + l + in let results = List.map Moonpool.Fut.wait_block futs in Moonpool.Blocking_queue.close queue; - List.map (function - | Ok x -> x - | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt - ) results + List.map + (function + | Ok x -> x + | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt) + results with e -> Logs.debug (fun m -> m "par-map: shutdown pool (exception)"); Moonpool.Blocking_queue.close queue; @@ -477,27 +484,27 @@ let mk_socket sockaddr = sock, (Unix.getnameinfo (Unix.getsockname sock) []).ni_service (** [start_server n server_fun sock] starts a server on the socket [sock], - assumes that the socket is correcly bound to a valid address. - Allows up to [n] connections and runs the function [server_fun] for each - connection on a separate thread (uses threads, doesn't fork the process).*) + assumes that the socket is correcly bound to a valid address. Allows up to + [n] connections and runs the function [server_fun] for each connection on a + separate thread (uses threads, doesn't fork the process).*) let start_server n server_fun sock = let open Unix in listen sock 5; let threads = List.init n (fun _ -> - Thread.create (fun () -> - let s, _caller = accept_non_intr sock in - let inchan = in_channel_of_descr s in - let outchan = out_channel_of_descr s in - server_fun inchan outchan - ) () - ) + Thread.create + (fun () -> + let s, _caller = accept_non_intr sock in + let inchan = in_channel_of_descr s in + let outchan = out_channel_of_descr s in + server_fun inchan outchan) + ()) in List.iter Thread.join threads -(** [establish_server n server_fun sockaddr] same as - [Unix.establish_server], but it uses threads instead of forking the process - after each connection, and only accepts [n] connections *) +(** [establish_server n server_fun sockaddr] same as [Unix.establish_server], + but it uses threads instead of forking the process after each connection, + and only accepts [n] connections *) let establish_server n server_fun sockaddr = let sock, _ = mk_socket sockaddr in start_server n server_fun sock diff --git a/src/core/Problem.mli b/src/core/Problem.mli index d544767..135483b 100644 --- a/src/core/Problem.mli +++ b/src/core/Problem.mli @@ -12,9 +12,8 @@ val find_expect : ?default_expect:Res.t -> expect:Dir.expect -> path -> Res.t (** FInd the expected result for this given problem *) val make_find_expect : expect:Dir.expect -> path -> t -(** [make_find_expect ~expect file] tries to find the expected - result of [file] using [expect], and - makes a problem if it finds the result +(** [make_find_expect ~expect file] tries to find the expected result of [file] + using [expect], and makes a problem if it finds the result @param expect the method for finding expected result *) val basename : t -> string @@ -28,17 +27,14 @@ val compare_name : t -> t -> int val compare_res : t -> Res.t -> [ `Same | `Improvement | `Mismatch | `Disappoint | `Error ] -(** [compare_res pb res] compares the expected result of [pb] to - the actual result [res], yielding one of: - - {ul - {- `Same if they coincide} - {- `Mismatch if they do not match in an unsound way (error)} - {- `Disappoint if the result is not incorrect, but less good than expected} - {- `Improvement if unknown was expected, but sat|unsat was found} - {- `Error if the actual result is an error but not the expect result} - } -*) +(** [compare_res pb res] compares the expected result of [pb] to the actual + result [res], yielding one of: + + - `Same if they coincide + - `Mismatch if they do not match in an unsound way (error) + - `Disappoint if the result is not incorrect, but less good than expected + - `Improvement if unknown was expected, but sat|unsat was found + - `Error if the actual result is an error but not the expect result *) val pp : t Fmt.printer val name : t -> string diff --git a/src/core/Proof_checker.mli b/src/core/Proof_checker.mli index 4016ece..938dbcd 100644 --- a/src/core/Proof_checker.mli +++ b/src/core/Proof_checker.mli @@ -20,8 +20,9 @@ val make_cmd : t -> string (** Interpolate a command using the given substitution function. - @raise Subst_not_found if a variable is found, that is not substituted - into any of the parameters nor by [f] *) + @raise Subst_not_found + if a variable is found, that is not substituted into any of the parameters + nor by [f] *) module Res = Proof_check_res diff --git a/src/core/Prover.mli b/src/core/Prover.mli index c0ac8e6..3728526 100644 --- a/src/core/Prover.mli +++ b/src/core/Prover.mli @@ -2,8 +2,7 @@ (** {1 Run Prover} - Utils to run a theorem prover (or a similar tool) and extract its result -*) + Utils to run a theorem prover (or a similar tool) and extract its result *) open Common @@ -64,15 +63,13 @@ val equal : t -> t -> bool (** Equality (by name) *) exception Subst_not_found of string -(** Raised during substitution when a pattern to substitute - was unknown. - TODO: maybe simply leave these patterns as is ? *) +(** Raised during substitution when a pattern to substitute was unknown. TODO: + maybe simply leave these patterns as is ? *) exception Missing_subst_value of string -(** Raised during substitution when a known pattern was to - be substituted, but there was no available value for - that parameter (i.e. typically, the optional argument to the - subst function was not provided / was [None]). *) +(** Raised during substitution when a known pattern was to be substituted, but + there was no available value for that parameter (i.e. typically, the + optional argument to the subst function was not provided / was [None]). *) val subst : ?binary:string -> @@ -82,19 +79,20 @@ val subst : unit -> string -> string -(** Return a substitution function adequate for {!interpolate_cmd}, - that performs the substitutions of the given parameters (binary, - memory, timeout, file) or defers to the fallback [?f] argument. +(** Return a substitution function adequate for {!interpolate_cmd}, that + performs the substitutions of the given parameters (binary, memory, timeout, + file) or defers to the fallback [?f] argument. @raise Subst_not_found when the fallback function returns [None] - @raise Missing_subst_value when a parameter that is know to be - substituted (e.g. "$file"), was not given a value (e.g. - [?file:None]). *) + @raise Missing_subst_value + when a parameter that is know to be substituted (e.g. "$file"), was not + given a value (e.g. [?file:None]). *) val interpolate_cmd : ?env:(string * string) array -> subst:(string -> string) -> string -> string (** Interpolate a command using the given substitution function. - @raise Subst_not_found if a variable is found, that is not substituted - into any of the parameters nor by [f] *) + @raise Subst_not_found + if a variable is found, that is not substituted into any of the parameters + nor by [f] *) val make_command : ?env:(string * string) array -> diff --git a/src/core/Res.ml b/src/core/Res.ml index fd37f01..aa7648f 100644 --- a/src/core/Res.ml +++ b/src/core/Res.ml @@ -41,7 +41,7 @@ let compare a b = `Same | Tag s1, Tag s2 when s1 = s2 -> `Same - (* + (* | Unknown, Timeout -> `LeftBetter | Timeout, Unknown -> `RightBetter *) diff --git a/src/core/Res.mli b/src/core/Res.mli index b18299c..f8adaaa 100644 --- a/src/core/Res.mli +++ b/src/core/Res.mli @@ -5,16 +5,13 @@ type t = Sat | Unsat | Unknown | Timeout | Error | Tag of string val compare : t -> t -> [ `Same | `LeftBetter | `RightBetter | `Mismatch ] -(** [compare a b] compares results [a] and [b] (assuming they are results - of two distinct provers on the same problem), and returns: +(** [compare a b] compares results [a] and [b] (assuming they are results of two + distinct provers on the same problem), and returns: - {ul - {- `Same if results coincide} - {- `Mismatch if they are not compatible (error)} - {- `LeftBetter if [b = Unknown] and [a = Sat] or [a = Unsat]} - {- `RightBetter if [a = Unknown] and [b = Sat] or [b = Unsat]} - } -*) + - `Same if results coincide + - `Mismatch if they are not compatible (error) + - `LeftBetter if [b = Unknown] and [a = Sat] or [a = Unsat] + - `RightBetter if [a = Unknown] and [b = Sat] or [b = Unsat] *) val pp : t CCFormat.printer val to_string : t -> string diff --git a/src/core/Run_event.ml b/src/core/Run_event.ml index 0b6ac2e..863455e 100644 --- a/src/core/Run_event.ml +++ b/src/core/Run_event.ml @@ -107,8 +107,18 @@ let of_db_provers_map db ~f : _ list = Db.Ty.( ( p4 text text text text @>> p2 int int @>> p2 blob blob @>> p3 float float float, - fun pname pb_name res expected timeout errcode stdout stderr rtime - utime stime -> + fun pname + pb_name + res + expected + timeout + errcode + stdout + stderr + rtime + utime + stime + -> let pb = { Problem.name = pb_name; diff --git a/src/core/Sexp_decode.mli b/src/core/Sexp_decode.mli index 0a9ebb9..beb1503 100644 --- a/src/core/Sexp_decode.mli +++ b/src/core/Sexp_decode.mli @@ -38,26 +38,26 @@ val is_atom : bool t val is_list : bool t val succeeds : 'a t -> bool t -(** [succeeds d] returns [true] if [d] parses the S-expr, and [false] otherwise. *) +(** [succeeds d] returns [true] if [d] parses the S-expr, and [false] otherwise. +*) val is_applied : string -> bool t -(** [is_applied "foo"] is the recognizer that - accepts expressions of the form [("foo" …)] *) +(** [is_applied "foo"] is the recognizer that accepts expressions of the form + [("foo" …)] *) val try_succeed : 'a t -> bool t * 'a t (** [try_succeed d] is [succeeds d, d] *) val try_l : msg:string -> (bool t * 'a t) list -> 'a t -(** [try_l ~msg l] parses a sexp by trying each case in [l] successively, - until one succeeds. - A case is a pair of a recognizer and a parser. If the recognizer succeeds, - then this case wins, and [try_l l] behaves like the case's parser; - if the recognizer fails, the case is discarded and the next case is tried. +(** [try_l ~msg l] parses a sexp by trying each case in [l] successively, until + one succeeds. A case is a pair of a recognizer and a parser. If the + recognizer succeeds, then this case wins, and [try_l l] behaves like the + case's parser; if the recognizer fails, the case is discarded and the next + case is tried. @param msg error message if no case recognizes the parser. *) val with_msg : msg:string -> 'a t -> 'a t -(** [with_msg ~msg d] behaves like [d] but replaces - [d]'s errors with [msg] *) +(** [with_msg ~msg d] behaves like [d] but replaces [d]'s errors with [msg] *) val map_l : ('a -> 'b t) -> 'a list -> 'b list t val fold_l : ('b -> 'a -> 'b t) -> 'b -> 'a list -> 'b t @@ -70,21 +70,18 @@ val applied2 : string -> 'a t -> 'b t -> ('a * 'b) t val applied3 : string -> 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val try_apply : string -> (sexp list -> 'a t) -> 'a t -> 'a t -(** [try_apply f ok else_] tries to parse the sexp [(f x1…xn)], - in which case it calls [ok [x1;…;xn]]. Otherwise it - calls [else_] on the root sexp. *) +(** [try_apply f ok else_] tries to parse the sexp [(f x1…xn)], in which case it + calls [ok [x1;…;xn]]. Otherwise it calls [else_] on the root sexp. *) module Fields : sig type t - (** A mutable collection of pairs (key-value), used to represent - records *) + (** A mutable collection of pairs (key-value), used to represent records *) val field : t -> string -> 'a m -> 'a m - (** [field m name d] gets and consume the pair [(, v)] from [m], - using [d] to decode [v]. - This fails if the field is not present. It removes it from [m] - on success, so must never be called twice with the same field name - on a given collection. *) + (** [field m name d] gets and consume the pair [(, v)] from [m], using + [d] to decode [v]. This fails if the field is not present. It removes it + from [m] on success, so must never be called twice with the same field + name on a given collection. *) val field_opt : t -> string -> 'a m -> 'a option m (** Same as {!field} but doesn't fail if the field is absent. *) @@ -94,8 +91,7 @@ module Fields : sig val check_no_field_left : t -> unit m (** Check that all fields have been consumed by {!field} and {!field_opt} - above. - This fails if there are some pairs that were not used at all, which + above. This fails if there are some pairs that were not used at all, which is useful to detect typos and unrecognized inputs. *) end @@ -103,8 +99,8 @@ val fields : Fields.t t (** Parses a list of pairs [((a b) (c d) …)] as a record. *) val applied_fields : string -> Fields.t t -(** [applied_fields "foo"] accepts [("foo" (a b) (c d) …)] - and returns the corresponding list of fields. *) +(** [applied_fields "foo"] accepts [("foo" (a b) (c d) …)] and returns the + corresponding list of fields. *) type err diff --git a/src/core/Slurm_cmd.ml b/src/core/Slurm_cmd.ml index a198d52..921c921 100644 --- a/src/core/Slurm_cmd.ml +++ b/src/core/Slurm_cmd.ml @@ -1,19 +1,21 @@ -(** [sbatch ?options script] creates a "sbatch" command that submits the script located in the path [script] with the command line options [?options]. *) +(** [sbatch ?options script] creates a "sbatch" command that submits the script + located in the path [script] with the command line options [?options]. *) let sbatch ?(options = []) ?(wrap = false) target = Format.sprintf "%s %s" (Misc.mk_shell_cmd ~options "sbatch") (if wrap then - Format.sprintf "--wrap=\"%s\"" target - else - target) + Format.sprintf "--wrap=\"%s\"" target + else + target) -(** [srun ?options cmd] creates an "srun" command that executes the command [cmd] with the command line options [?options]. *) +(** [srun ?options cmd] creates an "srun" command that executes the command + [cmd] with the command line options [?options]. *) let srun ?(options = []) cmd = Format.sprintf "%s %s" (Misc.mk_shell_cmd ~options "srun") cmd -(** [grep_job_id sbatch_cmd] Given a "sbatch" command, generates a command - that extracts from the output of the "sbatch" command the ID of the job - that was submitted. *) +(** [grep_job_id sbatch_cmd] Given a "sbatch" command, generates a command that + extracts from the output of the "sbatch" command the ID of the job that was + submitted. *) let grep_job_id sbatch_cmd = Format.sprintf "%s | grep -oP \"^Submitted batch job \\K[0-9]+$\"" sbatch_cmd diff --git a/src/core/Stanza.mli b/src/core/Stanza.mli index a2bdcc7..14f60f0 100644 --- a/src/core/Stanza.mli +++ b/src/core/Stanza.mli @@ -70,14 +70,14 @@ type t = loc: Loc.t; version: version_field option; binary: string option; - (** Path to the binary to use. Useful in combination with [inherits] *) + (** Path to the binary to use. Useful in combination with [inherits] + *) cmd: string option; - (** the command line to run. - possibly contains $binary, $file, $memory and $timeout, - and $proof_file if {!produces_proof} is true *) + (** the command line to run. possibly contains $binary, $file, $memory + and $timeout, and $proof_file if {!produces_proof} is true *) produces_proof: bool option; - (** true if the solver should be passed $proof_file into which - it can emit a proof *) + (** true if the solver should be passed $proof_file into which it can + emit a proof *) proof_ext: string option; (** file extension for proofs *) proof_checker: string option; (** name of proof checker *) ulimits: Ulimit.conf option; (** which limits to enforce using ulimit *) @@ -130,8 +130,7 @@ val errors : t list -> Error.t list val parse_files : ?reify_errors:bool -> string list -> t list (** Parse a list of files and return their concatenated stanzas. @param builtin if true, add the builtin prelude before the files - @param reify_errors if true, parsing errors become {!St_error} -*) + @param reify_errors if true, parsing errors become {!St_error} *) val parse_string : ?reify_errors:bool -> filename:string -> string -> t list (** Parse a string. See {!parse_files} for the arguments. diff --git a/src/core/Subdir.ml b/src/core/Subdir.ml index 1a48ada..948f872 100644 --- a/src/core/Subdir.ml +++ b/src/core/Subdir.ml @@ -1,9 +1,8 @@ module Fmt = CCFormat type t = { path: string; inside: Dir.t; loc: Loc.t } -(** A directory of problems, inside a known set of problems - which defines what patterns to search for, and how to read "expect" results. -*) +(** A directory of problems, inside a known set of problems which defines what + patterns to search for, and how to read "expect" results. *) let pp out (self : t) = let open Misc.Pp in diff --git a/src/core/Task_queue.ml b/src/core/Task_queue.ml index 59fef6b..dd8626c 100644 --- a/src/core/Task_queue.ml +++ b/src/core/Task_queue.ml @@ -22,9 +22,9 @@ module Job = struct let pp out self = Fmt.fprintf out "(@[task%s@ :uuid %s@ %a@])" (if M.get self.j_interrupted then - "[int]" - else - "") + "[int]" + else + "") self.j_uuid Action.pp self.j_action let uuid self = self.j_uuid diff --git a/src/core/Test_compare.ml b/src/core/Test_compare.ml index e1ea89d..ca10ecb 100644 --- a/src/core/Test_compare.ml +++ b/src/core/Test_compare.ml @@ -23,8 +23,7 @@ let cmp2sql = function or (r1.res not in ('sat', 'unsat') and r2.res not in ('sat', 'unsat')) |} - | `Solved -> - {| (r1.res in ('sat', 'unsat') and r1.res = r2.res) |} + | `Solved -> {| (r1.res in ('sat', 'unsat') and r1.res = r2.res) |} | `Mismatch -> {| r1.res in ('sat', 'unsat') and @@ -139,8 +138,10 @@ module Short = struct and file = r1.file); |} and same = get_n (unsafe_sql ?status ~filter:`Same [ "count(r1.file)" ]) and solved = get_n (unsafe_sql ?status ~filter:`Solved [ "count(r1.file)" ]) - and old_time = get_flt (unsafe_sql ?status ~filter:`Solved [ "sum(r1.rtime)" ]) - and new_time = get_flt (unsafe_sql ?status ~filter:`Solved [ "sum(r2.rtime)" ]) + and old_time = + get_flt (unsafe_sql ?status ~filter:`Solved [ "sum(r1.rtime)" ]) + and new_time = + get_flt (unsafe_sql ?status ~filter:`Solved [ "sum(r2.rtime)" ]) and mismatch = get_n (unsafe_sql ?status ~filter:`Mismatch [ "count(r1.file)" ]) and improved = @@ -148,8 +149,17 @@ module Short = struct and regressed = get_n (unsafe_sql ?status ~filter:`Regressed [ "count(r1.file)" ]) in - { appeared; disappeared; same; solved; mismatch; improved; regressed - ; old_time ; new_time } + { + appeared; + disappeared; + same; + solved; + mismatch; + improved; + regressed; + old_time; + new_time; + } let make_provers ?status (f1, p1) (f2, p2) : t = Error.guard @@ -182,7 +192,10 @@ module Full = struct let make_filtered ?(page = 0) ?(page_size = 500) ?filter ?status (f1, p1) (f2, p2) = - let tags = [] (* TODO? *) in + let tags = + [] + (* TODO? *) + in let offset = page * page_size in let limit = page_size + 1 in Db.exec (make_db f1 f2) diff --git a/src/core/Test_compare.mli b/src/core/Test_compare.mli index 504e128..1e7383f 100644 --- a/src/core/Test_compare.mli +++ b/src/core/Test_compare.mli @@ -21,7 +21,8 @@ module Short : sig val make : ?status:status -> filename -> filename -> (Prover.name * t) list val make_provers : ?status:status -> prover -> prover -> t - (** Make a single comparison between two provers in (possibly) different files *) + (** Make a single comparison between two provers in (possibly) different files + *) end module Full : sig diff --git a/src/core/Test_detailed_res.ml b/src/core/Test_detailed_res.ml index 5f9c8a2..e44bfba 100644 --- a/src/core/Test_detailed_res.ml +++ b/src/core/Test_detailed_res.ml @@ -147,15 +147,9 @@ let get_res db prover file : _ * proof_check_res option = |> Error.unwrap_opt' (fun () -> spf "expected a non-empty result for prover='%s', file='%s'" prover file) - |> fun ( res, - file_expect, - timeout, - errcode, - stdout, - stderr, - rtime, - utime, - stime ) -> + |> + fun (res, file_expect, timeout, errcode, stdout, stderr, rtime, utime, stime) + -> let stdout = CCOpt.get_or ~default:"" stdout in let stderr = CCOpt.get_or ~default:"" stderr in Logs.debug (fun k -> k "res.of_string tags=[%s]" (String.concat "," tags)); diff --git a/src/core/Test_detailed_res.mli b/src/core/Test_detailed_res.mli index 0fe459d..b8a55fa 100644 --- a/src/core/Test_detailed_res.mli +++ b/src/core/Test_detailed_res.mli @@ -33,9 +33,10 @@ val list_keys : Db.t -> key list * int * bool (** List available results. - @returns tuple [l, n, is_done], where [is_done] is true if there are - no more results, and [n] is the total number of results (not just - those in [l]). *) + @return + tuple [l, n, is_done], where [is_done] is true if there are no more + results, and [n] is the total number of results (not just those in [l]). +*) type proof_check_res = { res: Proof_check_res.t; stdout: string; rtime: float } @@ -44,7 +45,8 @@ val to_printbox : t -> proof_check_res option -> PrintBox.t * PrintBox.t * string * string * string option -(** Display an individual result + prover descr + stdout + stderr + proof stdout *) +(** Display an individual result + prover descr + stdout + stderr + proof stdout +*) val get_res : Db.t -> Prover.name -> string -> t * proof_check_res option (** Get an individual result *) diff --git a/src/core/Test_metadata.ml b/src/core/Test_metadata.ml index a3cb53d..0ffff64 100644 --- a/src/core/Test_metadata.ml +++ b/src/core/Test_metadata.ml @@ -20,9 +20,9 @@ let pp out (self : t) : unit = %a@]" self.n_results (if self.n_bad > 0 then - Printf.sprintf " bad: %d" self.n_bad - else - "") + Printf.sprintf " bad: %d" self.n_bad + else + "") (String.concat ";" self.provers) (CCOpt.map_or ~default:"" Misc.human_datetime self.timestamp) (CCOpt.map_or ~default:"" Misc.human_duration @@ -41,9 +41,9 @@ let to_printbox ?link:(mk_link = default_linker) self : PB.t = "n_results", int self.n_results; ]; (if self.n_bad > 0 then - [ "bad", int self.n_bad ] - else - []); + [ "bad", int self.n_bad ] + else + []); [ "uuid", text @@ Uuidm.to_string self.uuid; "dirs", hlist_map text self.dirs; diff --git a/src/core/Test_stat.ml b/src/core/Test_stat.ml index e56d83b..57e6edd 100644 --- a/src/core/Test_stat.ml +++ b/src/core/Test_stat.ml @@ -2,8 +2,8 @@ open Common open Test module PB = PrintBox -(** Aggregate function computing the mean and the standard deviation - of data series using the Welford's algorithm. *) +(** Aggregate function computing the mean and the standard deviation of data + series using the Welford's algorithm. *) module Stats = struct type acc = { n: int; total: float; mean: float * float; s: float * float } diff --git a/src/core/Test_top_result.mli b/src/core/Test_top_result.mli index 2badb53..0c90ed9 100644 --- a/src/core/Test_top_result.mli +++ b/src/core/Test_top_result.mli @@ -1,7 +1,7 @@ (** Top Result for a benchmark run. - Main result of testing: a snapshot of the work done, + the analysis - per prover *) + Main result of testing: a snapshot of the work done, + the analysis per + prover *) open Common open Test diff --git a/src/core/Ulimit.ml b/src/core/Ulimit.ml index 8fd1993..b32dcf4 100644 --- a/src/core/Ulimit.ml +++ b/src/core/Ulimit.ml @@ -18,19 +18,19 @@ let pp out t = else CCFormat.fprintf out "(%a%a%a)" CCFormat.string (if t.time then - "time " - else - "") + "time " + else + "") CCFormat.string (if t.memory then - "memory " - else - "") + "memory " + else + "") CCFormat.string (if t.stack then - "stack" - else - "") + "stack" + else + "") (* Prefix a command to enforce a set of limits *) let prefix_cmd ~conf ~limits ~cmd = diff --git a/src/core/Ulimit.mli b/src/core/Ulimit.mli index edd3014..5d104a4 100644 --- a/src/core/Ulimit.mli +++ b/src/core/Ulimit.mli @@ -1,8 +1,7 @@ (** Ulimit handling of limits *) type conf = { time: bool; memory: bool; stack: bool } -(** The configuration of ulimit, aka which limits to enforce - via ulimit. *) +(** The configuration of ulimit, aka which limits to enforce via ulimit. *) val hash : conf -> int val equal : conf -> conf -> bool diff --git a/src/core/Xdg.mli b/src/core/Xdg.mli index 36fae16..51864f5 100644 --- a/src/core/Xdg.mli +++ b/src/core/Xdg.mli @@ -1,7 +1,8 @@ (** Basic XDG config We follow losely - https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html *) + https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html +*) val name_of_project : string ref val get_home : unit -> string @@ -9,8 +10,7 @@ val get_home : unit -> string val interpolate_home : ?f:(string -> string option) -> string -> string (** Replace [$HOME] by the home directory in this string. @param f used to interpolate other keys - @raise Failure if another key is met -*) + @raise Failure if another key is met *) val config_dir : unit -> string (** Where to search for configuration *) @@ -19,8 +19,8 @@ val data_dir : unit -> string (** Where to store permanent data *) val cache_dir : unit -> string -(** Where to store disposable data that is only useful for improving perf - but can be erased at any point *) +(** Where to store disposable data that is only useful for improving perf but + can be erased at any point *) val runtime_dir : unit -> string (** Where to store runtime files such as unix sockets *) diff --git a/src/core/dune b/src/core/dune index f4e77a7..7eeecfa 100644 --- a/src/core/dune +++ b/src/core/dune @@ -5,9 +5,9 @@ (synopsis "Benchpress core library, with all the data structures and functions") (wrapped true) - (libraries containers containers.unix moonpool re re.perl csv iter - printbox printbox-text logs logs.cli gnuplot ptime ptime.clock.os uuidm - sqlite3 sqlite3_utils cmdliner pp_loc processor) + (libraries containers containers.unix moonpool re re.perl csv iter printbox + printbox-text logs logs.cli gnuplot ptime ptime.clock.os uuidm sqlite3 + sqlite3_utils cmdliner pp_loc processor) (flags :standard -w -5 -warn-error -a+8 -strict-sequence)) (rule diff --git a/src/lsp/benchpress_lsp.ml b/src/lsp/benchpress_lsp.ml index 20b3437..17c3918 100644 --- a/src/lsp/benchpress_lsp.ml +++ b/src/lsp/benchpress_lsp.ml @@ -48,7 +48,8 @@ let diag_of_error ~uri (e0 : Error.t) : LT.Diagnostic.t list = match errs with | [] -> - Log.err (fun k -> k "in %s: err with no loc:@ %a" (uri_to_string uri) Error.pp e0); + Log.err (fun k -> + k "in %s: err with no loc:@ %a" (uri_to_string uri) Error.pp e0); [] | (msg0, loc0) :: ctx_errs -> let d = @@ -102,11 +103,11 @@ class blsp = inherit L.server (* one env per document *) - val buffers : (Linol.Lsp.Types.DocumentUri.t, processed_buf) Hashtbl.t Lock.t = + val buffers + : (Linol.Lsp.Types.DocumentUri.t, processed_buf) Hashtbl.t Lock.t = Lock.create @@ Hashtbl.create 32 method spawn_query_handler f = ignore (Thread.create (fun () -> f ()) ()) - method! config_hover = Some (`Bool true) method! config_definition = Some (`Bool true) @@ -121,8 +122,8 @@ class blsp = ~save:(`SaveOptions (LT.SaveOptions.create ~includeText:false ())) () - method! on_req_hover ~notify_back:_ ~id:_ ~uri ~pos ~workDoneToken:_ (_ : L.doc_state) - : LT.Hover.t option = + method! on_req_hover ~notify_back:_ ~id:_ ~uri ~pos ~workDoneToken:_ + (_ : L.doc_state) : LT.Hover.t option = let pos = Loc.Pos.of_line_col pos.L.Position.line pos.character in match Lock.with_ buffers (fun b -> CCHashtbl.get b uri) with | Some { defs = Ok defs; text; _ } -> @@ -146,8 +147,8 @@ class blsp = Some h)) | _ -> None - method! on_req_definition ~notify_back:_ ~id:_ ~uri ~pos ~workDoneToken:_ ~partialResultToken:_ (_ : L.doc_state) - : LT.Locations.t option = + method! on_req_definition ~notify_back:_ ~id:_ ~uri ~pos ~workDoneToken:_ + ~partialResultToken:_ (_ : L.doc_state) : LT.Locations.t option = let pos = Loc.Pos.of_line_col pos.L.Position.line pos.character in match Lock.with_ buffers (fun b -> CCHashtbl.get b uri) with | Some { defs = Ok defs; text; _ } -> @@ -169,14 +170,14 @@ class blsp = (* FIXME: completion is never useful on a parsable buffer, and buffers that do not parse have no definitions *) - method! on_req_completion ~notify_back:_ ~id:_ ~uri ~pos ~ctx:_ ~workDoneToken:_ ~partialResultToken:_ - (_ : L.doc_state) - : [ `CompletionList of LT.CompletionList.t - | `List of LT.CompletionItem.t list ] - option = + method! on_req_completion ~notify_back:_ ~id:_ ~uri ~pos ~ctx:_ + ~workDoneToken:_ ~partialResultToken:_ (_ : L.doc_state) : + [ `CompletionList of LT.CompletionList.t + | `List of LT.CompletionItem.t list ] + option = Log.debug (fun k -> - k "completion request in '%s' at pos: %d line, %d col" (uri_to_string uri) pos.line - pos.character); + k "completion request in '%s' at pos: %d line, %d col" + (uri_to_string uri) pos.line pos.character); let pos = Loc.Pos.of_line_col pos.line pos.character in match Lock.with_ buffers (fun b -> CCHashtbl.get b uri) with | Some { defs = Ok defs; text; _ } -> @@ -212,7 +213,8 @@ class blsp = let open E.Infix in let stanzas = catch_e @@ fun () -> - Stanza.parse_string ~reify_errors:true ~filename:(uri_to_string uri) contents + Stanza.parse_string ~reify_errors:true ~filename:(uri_to_string uri) + contents in let defs = let* stanzas = stanzas in diff --git a/src/server/benchpress_server.ml b/src/server/benchpress_server.ml index 283d76f..2de01b5 100644 --- a/src/server/benchpress_server.ml +++ b/src/server/benchpress_server.ml @@ -153,8 +153,8 @@ end = struct | _ -> (* catch-all to be more resilient to newer versions of printbox *) H.div [] [ H.pre [] [ H.txt @@ PrintBox_text.to_string b ] ] - (* remaining cases *) - [@@warning "-11"] + (* remaining cases *) + [@@warning "-11"] let to_html b = H.div [] [ to_html_rec b ] end @@ -241,16 +241,16 @@ let mk_navigation ?(btns = []) path = [ mk_a [ A.href uri ] [ txt descr ] ]) path); (if btns = [] then - `Nil - else - sub_e - (div - [ - A.class_ - "btn-group-vertical col-sm-1 align-items-center \ - navbar-right m-2"; - ] - btns)); + `Nil + else + sub_e + (div + [ + A.class_ + "btn-group-vertical col-sm-1 align-items-center \ + navbar-right m-2"; + ] + btns)); ] (* default reply headers *) @@ -283,21 +283,21 @@ let uri_show_detailed ?(offset = 0) ?(filter_prover = "") ?(filter_pb = "") ?(filter_res = "") ?(filter_expect = "") pb = spf "/show_detailed/%s/?%s%s%s%soffset=%d" (U.percent_encode pb) (if filter_prover = "" then - "" - else - spf "prover=%s&" @@ U.percent_encode filter_prover) + "" + else + spf "prover=%s&" @@ U.percent_encode filter_prover) (if filter_pb = "" then - "" - else - spf "pb=%s&" @@ U.percent_encode filter_pb) + "" + else + spf "pb=%s&" @@ U.percent_encode filter_pb) (if filter_res = "" then - "" - else - spf "res=%s&" @@ U.percent_encode filter_res) + "" + else + spf "res=%s&" @@ U.percent_encode filter_res) (if filter_expect = "" then - "" - else - spf "expect=%s&" @@ U.percent_encode filter_expect) + "" + else + spf "expect=%s&" @@ U.percent_encode filter_expect) offset let uri_list_benchs ~off ?limit () : string = @@ -356,9 +356,9 @@ let query_wrap wrap (f : Misc.Chrono.t -> _) : H.Response.t = Log.debug (fun k -> k "%s (code %d) after %.3fs" (if succ then - "successful reply" - else - "failure") + "successful reply" + else + "failure") code duration); h | exception E (e, code) -> @@ -459,10 +459,10 @@ let handle_show (self : t) : unit = ]; ]; (if box_compare_l = PB.empty then - `Nil - else - sub_l - [ h3 [] [ txt "comparisons" ]; div [] [ pb_html box_compare_l ] ]); + `Nil + else + sub_l + [ h3 [] [ txt "comparisons" ]; div [] [ pb_html box_compare_l ] ]); ] in Log.debug (fun k -> @@ -713,9 +713,9 @@ let handle_show_as_table (self : t) : unit = mk_a ~cls: ((if offset > 0 then - "" - else - "disabled ") + "" + else + "disabled ") ^ "page-link link-sm my-1 p-1") [ A.href @@ -734,9 +734,9 @@ let handle_show_as_table (self : t) : unit = uri_show file, "file", false; ( uri_show_table file, (if offset = 0 then - "full" - else - spf "full[%d..]" offset), + "full" + else + spf "full[%d..]" offset), true ); ]; div @@ -882,9 +882,9 @@ let handle_show_detailed (self : t) : unit = mk_a ~cls: ((if offset > 0 then - "" - else - "disabled ") + "" + else + "disabled ") ^ "page-link link-sm my-1 p-1") [ A.href @@ -911,9 +911,9 @@ let handle_show_detailed (self : t) : unit = uri_show db_file, "file", false; ( uri_show_detailed db_file, (if offset = 0 then - "detailed" - else - spf "detailed [%d..%d]" offset (offset + List.length l - 1)), + "detailed" + else + spf "detailed [%d..%d]" offset (offset + List.length l - 1)), true ); ]; div @@ -1166,9 +1166,9 @@ let handle_compare2 self : unit = A.value (file_basename ^ "/" ^ prover) :: (if selected = Some (file_basename, prover) then - [ A.selected "selected" ] - else - []) + [ A.selected "selected" ] + else + []) in option attrs [ txt prover ]) meta.provers) @@ -1186,9 +1186,9 @@ let handle_compare2 self : unit = A.value (status_opt_to_string status) :: (if current = Some status then - [ A.selected "selected" ] - else - []) + [ A.selected "selected" ] + else + []) in option attrs [ txt (status_opt_to_string status) ] in @@ -1577,23 +1577,23 @@ let html_of_files (self : t) ~off ~limit : Html.elt list = [ txt (Printf.sprintf "(%s)" (Misc.human_size size)) ]; ]; (if self.allow_delete then - div - [ A.class_ "col-md-2 justify-self-right" ] - [ - mk_button ~cls:"btn-warning btn-sm" - [ - ( "hx-delete", - "/delete1/" ^ U.percent_encode file_path ^ "/" ); - "hx-confirm", "Confirm deletion?"; - "hx-target", spf "#%s" id; - (* remove whole "li" element *) - "hx-swap", "outerHTML"; - A.title "delete file"; - ] - [ txt "delete" ]; - ] - else - div [] []); + div + [ A.class_ "col-md-2 justify-self-right" ] + [ + mk_button ~cls:"btn-warning btn-sm" + [ + ( "hx-delete", + "/delete1/" ^ U.percent_encode file_path ^ "/" ); + "hx-confirm", "Confirm deletion?"; + "hx-target", spf "#%s" id; + (* remove whole "li" element *) + "hx-swap", "outerHTML"; + A.title "delete file"; + ] + [ txt "delete" ]; + ] + else + div [] []); div [ A.class_ "col-md-1 justify-self-right" ] [ input [ A.type_ "checkbox"; A.name file_basename ] ]; @@ -1737,8 +1737,8 @@ let handle_file self : unit = H.Response.fail_raise ~code:404 "cannot open file %S:\n\ %s\n\n\ - The benchmark might not be present on this machine." file - (Printexc.to_string e) + The benchmark might not be present on this machine." + file (Printexc.to_string e) ) in H.Response.make_raw_stream diff --git a/src/server/dune b/src/server/dune index 9db7e3b..88d9e7c 100644 --- a/src/server/dune +++ b/src/server/dune @@ -6,8 +6,8 @@ (promote (into ../../) (until-clean)) - (libraries benchpress containers cmdliner uuidm logs logs.cli - tiny_httpd tiny_httpd.prometheus sqlite3_utils base64 printbox jemalloc) + (libraries benchpress containers cmdliner uuidm logs logs.cli tiny_httpd + tiny_httpd.prometheus sqlite3_utils base64 printbox jemalloc) (flags :standard -warn-error -a+8 -safe-string -open Benchpress -linkall)) (rule