diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..6bafbd1 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1 @@ +profile=compact diff --git a/.travis.yml b/.travis.yml index 3a8ae25..1a37502 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,7 +5,4 @@ os: - linux - osx env: - - OCAML_VERSION=4.03.0 OPAM_VERSION=1.2.1 DOCKER_BUILD=false - - OCAML_VERSION=4.04.2 OPAM_VERSION=1.2.1 DOCKER_BUILD=false - - OCAML_VERSION=4.05.0 OPAM_VERSION=1.2.1 DOCKER_BUILD=false - - OCAML_VERSION=4.06.1 OPAM_VERSION=1.2.1 DOCKER_BUILD=true + - OCAML_VERSION=4.06.1 DOCKER_BUILD=true diff --git a/README.md b/README.md index 07f7bf5..c88f715 100644 --- a/README.md +++ b/README.md @@ -36,10 +36,9 @@ You can also build locally: You need OCaml ≥ 4.03.0 together with [`nonstd`](http://www.hammerlab.org/docs/nonstd/master/index.html), [`sosa`](http://www.hammerlab.org/docs/sosa/master/index.html), and -[`jbuilder`](https://github.com/janestreet/jbuilder): +[`dune`](https://github.com/janestreet/dune): - ocaml please.mlt configure - jbuilder build @install + dune build @install Getting Started --------------- @@ -148,7 +147,7 @@ To run the tests you also need `make` and there is an additional dependency on the `uri` library, see: genspio_test=_build/default/src/test/main.exe - jbuilder build $genspio_test + dune build $genspio_test $genspio_test --help diff --git a/doc/extra-testing.md b/doc/extra-testing.md index 49f08b2..fd39ef9 100644 --- a/doc/extra-testing.md +++ b/doc/extra-testing.md @@ -89,7 +89,7 @@ provides a command line tool to generate “Qemu” environments. You can build it with: export genspio_vm_tester=_build/default/src/examples/vm_tester.exe - jbuilder build $genspio_vm_tester + dune build $genspio_vm_tester A version is also available in the genspio-doc docker-images (note that the [build](https://hub.docker.com/r/smondet/genspio-doc-dockerfiles/builds/) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..1dddd07 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name genspio) diff --git a/genspio.opam b/genspio.opam index a071199..dadcefe 100644 --- a/genspio.opam +++ b/genspio.opam @@ -1,4 +1,3 @@ -# This Opam file was auto-generated, see the `please.mlt` script. opam-version: "2.0" maintainer: "Seb Mondet " authors: [ @@ -10,14 +9,13 @@ dev-repo: "git+https://github.com/hammerlab/genspio.git" license: "Apache 2.0" version: "0.0.3-dev" build: [ - ["ocaml" "please.mlt" "configure"] - ["jbuilder" "build" "-p" "genspio" "-j" jobs ] + ["dune" "build" "-p" name "-j" jobs ] ] depends: [ "ocaml" { >= "4.03.0" } - "jbuilder" {build & >= "1.0+beta20"} - "nonstd" - "sosa" + "dune" + "base" + "fmt" ] synopsis: "Typed EDSL to generate POSIX Shell scripts" description: """ diff --git a/please.mlt b/please.mlt deleted file mode 100644 index 2fb09a1..0000000 --- a/please.mlt +++ /dev/null @@ -1,72 +0,0 @@ -;; -#use "tools/please_lib.ml" - -let version = "0.0.3-dev" - -let main_libs = ["nonstd"; "sosa"] - -let toplevel_merlin = Merlin.lines ~s:["."; "tools"] ~pkg:main_libs () - -let meta_content = - String.concat ~sep:"\n" - [ "(** Metadata Module Generated by the Build System *)" - ; "" - ; sprintf "let version = %S" version ] - -let synopsis = "Typed EDSL to generate POSIX Shell scripts" - -let description = - "Genspio is a typed EDSL used to generate shell scripts and commands from \ - OCaml.\n\n\ - The idea is to build values of type `'a Genspio.EDSL.t` with the\n\ - combinators in the `Genspio.EDSL` module, and compile them to POSIX\n\ - shell scripts (or one-liners) with functions from `Genspio.Compile`.\n\n\ - Genspio's documentation root is at ." - -let describe _ = print_endline description - -let files = - let open File in - let open Jbuilder in - [ file ".merlin" toplevel_merlin - ; file "src/lib/jbuild" - @@ jbuild - [ rule ~targets:["meta.ml"] [write_file "meta.ml" meta_content] - ; lib "genspio" ~deps:main_libs ] - ; file "src/test-lib/jbuild" - @@ jbuild - [lib "tests" ~deps:("genspio" :: "uri" :: main_libs) ~internal:true] - ; file "src/test/jbuild" - @@ jbuild [executable "main" ~libraries:("genspio" :: "tests" :: main_libs)] - ; file "src/examples/jbuild" - @@ jbuild - [ executable ~single_module:true "downloader" - ~libraries:("genspio" :: main_libs) - ; executable ~single_module:true "vm_tester" - ~libraries:("genspio" :: main_libs) - ; executable ~single_module:true "service_composer" - ~libraries:("unix" :: "genspio" :: main_libs) - ; executable ~single_module:true "multigit" - ~libraries:("unix" :: "genspio" :: main_libs) - ; executable ~single_module:true "small" - ~libraries:("genspio" :: main_libs) - ; rule ~targets:["small_examples.ml"] ~deps:["small.exe"] - [sprintf "(run ./small.exe small_examples.ml)"] - ; executable ~single_module:true "small_examples" - ~libraries:("genspio" :: "tests" :: main_libs) ] - ; repo_file "genspio.opam" - Opam.( - v2 "genspio" ~maintainer:"Seb Mondet " - ~dev_repo:"git+https://github.com/hammerlab/genspio.git" - ~bug_reports:"https://github.com/hammerlab/genspio/issues" - ~homepage:"https://smondet.gitlab.io/genspio-doc/" - ~license:"Apache 2.0" ~version ~ocaml_min_version:"4.03.0" - ~description ~synopsis - ~deps: - ( Opam.dep - ~qualify:(`Version (`GT, "1.0+beta20")) - ~build:true "jbuilder" - :: List.map main_libs ~f:dep )) ] - -let () = - Main.make ~files ~describe ~version:(fun _ -> print_endline version) () diff --git a/src/examples/downloader.ml b/src/examples/downloader.ml index cc84058..b41149a 100644 --- a/src/examples/downloader.ml +++ b/src/examples/downloader.ml @@ -6,15 +6,13 @@ let downloader () = let say strings = let sayone ?(prompt = false) s = let prompt = if prompt then "downloader: " else "" in - call [string "printf"; string (prompt ^ "%s"); s] - in + call [string "printf"; string (prompt ^ "%s"); s] in match strings with | [] -> nop | s :: more -> seq ( (sayone ~prompt:true s :: List.map more ~f:sayone) - @ [sayone (string "\n")] ) - in + @ [sayone (string "\n")] ) in let sayf fmt = ksprintf (fun s -> say [string s]) fmt in let fail l = seq [say (string "ERROR: " :: l); fail "fail-list"] in let failf fmt = ksprintf (fun s -> fail [string s]) fmt in @@ -36,20 +34,16 @@ let downloader () = [ sayf "Expression %s failed!" name ; call [string "cat"; self#stderr] ; failf "Fatal failure of %s" name ] - end - in + end in let silence ~name unit = let s = silent ~name [unit] in - s#exec - in + s#exec in let succeed_in_silence_or_fail ~name units = let s = silent ~name units in - s#succeed_or_fail - in + s#succeed_or_fail in let download ~url ~output = let try_help ?(opt = "--help") cmd = - exec [cmd; opt] |> silence ~name:(cmd ^ opt) |> succeeds - in + exec [cmd; opt] |> silence ~name:(cmd ^ opt) |> succeeds in let do_call exec args = [ sayf "Using `%s`." exec ; succeed_in_silence_or_fail ~name:exec [call (string exec :: args)] ] @@ -59,22 +53,18 @@ let downloader () = (do_call "wget" [url; string "--output-document"; output]) ; case (try_help "curl") (do_call "curl" [string "-L"; string "-o"; output; url]) - ; default [failf "Can't find a downloading application"] ] - in + ; default [failf "Can't find a downloading application"] ] in let string_matches_any string regexp_list = (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) let options = List.concat_map regexp_list ~f:(fun r -> ["-e"; r]) in - string >> exec (["grep"; "-q"] @ options) |> succeeds - in + string >> exec (["grep"; "-q"] @ options) |> succeeds in let no_newline_sed ~input expr = let with_potential_newline = Str.concat_list [input; string "\n"] >> exec ["sed"; expr] |> get_stdout in - with_potential_newline >> exec ["tr"; "-d"; "\\n"] |> get_stdout - in + with_potential_newline >> exec ["tr"; "-d"; "\\n"] |> get_stdout in let module Unwrapper = struct type cmd = unit t - type t = {extension: string; verb: string; commands: file -> cmd list} let make ~ext ~verb commands = {extension= ext; verb; commands} @@ -92,8 +82,7 @@ let downloader () = (t.commands name_variable) ; name_variable#set (remove_suffix name_variable#get (sprintf "\\.%s" t.extension)) - ] - in + ] in seq [ say [string "Extract loop: "; name_variable#get] ; switch (List.map t_list ~f:make_case) ] @@ -101,29 +90,27 @@ let downloader () = let to_loop name_variable t_list = loop_while (string_matches_any name_variable#get - (List.map t_list (fun t -> sprintf "\\.%s$" t.extension))) + (List.map t_list ~f:(fun t -> sprintf "\\.%s$" t.extension))) ~body:(to_switch name_variable t_list) let all = [ make ~ext:"gz" ~verb:"Gunzipping" (fun current_name -> - [call [string "gunzip"; string "-f"; current_name#get]] ) + [call [string "gunzip"; string "-f"; current_name#get]]) ; make ~ext:"bz2" ~verb:"Bunzip2-ing" (fun current_name -> - [call [string "bunzip2"; string "-f"; current_name#get]] ) + [call [string "bunzip2"; string "-f"; current_name#get]]) ; make ~ext:"zip" ~verb:"Unzipping" (fun current_name -> - [call [string "unzip"; current_name#get]] ) + [call [string "unzip"; current_name#get]]) ; make ~ext:"tar" ~verb:"Untarring" (fun current_name -> - [call [string "tar"; string "xf"; current_name#get]] ) + [call [string "tar"; string "xf"; current_name#get]]) ; make ~ext:"tgz" ~verb:"Untar-gzip-ing" (fun name -> - [call [string "tar"; string "zxf"; name#get]] ) + [call [string "tar"; string "zxf"; name#get]]) ; make ~ext:"tbz2" ~verb:"Untar-bzip2-ing" (fun name -> - [call [string "tar"; string "xfj"; name#get]] ) + [call [string "tar"; string "xfj"; name#get]]) ; make ~ext:"gpg" ~verb:"Decyphering" (fun name -> [ call - [ string "gpg" - ; string "--output" + [ string "gpg"; string "--output" ; remove_suffix name#get "\\.gpg" - ; string "-d" - ; name#get ] ] ) ] + ; string "-d"; name#get ] ]) ] end in let no_value = sprintf "none_%x" (Random.int 100_000) |> string in let cli_spec = @@ -136,27 +123,23 @@ let downloader () = ~default:(str "/tmp/genspio-downloader-tmpdir") & usage "Download archives and decrypt/unarchive them.\n\ - ./downloader -u URL [-c] [-f ] [-t ]" - in - Command_line.parse cli_spec (fun ~anon url all_in_tmp filename_ov tmp_dir -> + ./downloader -u URL [-c] [-f ] [-t ]" in + Command_line.parse cli_spec + (fun ~anon:_ url all_in_tmp filename_ov tmp_dir -> let current_name = tmp_file ~tmp_dir "current-name" in let set_output_of_download () = if_seq Str.(filename_ov =$= no_value) ~t: (let filename = - no_newline_sed ~input:url "s/.*\\/\\([^?\\/]*\\).*/\\1/" - in + no_newline_sed ~input:url "s/.*\\/\\([^?\\/]*\\).*/\\1/" in let output_path = - Str.concat_list [tmp_dir; string "/"; filename] - in + Str.concat_list [tmp_dir; string "/"; filename] in [current_name#set output_path]) ~e: (let output_path = - Str.concat_list [tmp_dir; string "/"; filename_ov] - in - [current_name#set output_path]) - in + Str.concat_list [tmp_dir; string "/"; filename_ov] in + [current_name#set output_path]) in seq [ call [string "mkdir"; string "-p"; tmp_dir] ; if_then all_in_tmp @@ -171,9 +154,8 @@ let downloader () = ; Unwrapper.to_loop current_name Unwrapper.all ]) (seq [ fail - [ string "URL: " - ; url - ; string " -> not HTTP(s) or FTP: NOT IMPLEMENTED" ] ]) ] ) + [ string "URL: "; url + ; string " -> not HTTP(s) or FTP: NOT IMPLEMENTED" ] ]) ]) let () = match Sys.argv |> Array.to_list |> List.tl_exn with @@ -181,8 +163,7 @@ let () = let script = Genspio.Compile.to_many_lines (downloader ()) in let content = sprintf "#!/bin/sh\n\n# Generated by Genspio Example Tests\n\n%s\n%!" - script - in + script in match path with | "-" -> printf "\n`````\n%s`````\n%!" content | other -> @@ -191,6 +172,6 @@ let () = | other -> eprintf "Wrong command line: [%s]\n" (List.map ~f:(sprintf "%S") other |> String.concat ~sep:"; ") ; - eprintf "Usage:\n%s make \n\ Create the downloader script.\n%!" + eprintf "Usage:\n%s make \n Create the downloader script.\n%!" Sys.argv.(0) ; exit 1 diff --git a/src/examples/dune b/src/examples/dune new file mode 100644 index 0000000..c8fb822 --- /dev/null +++ b/src/examples/dune @@ -0,0 +1,8 @@ +(executable (name downloader) (libraries genspio nonstd sosa)(modules downloader)) +(executable (name vm_tester) (libraries genspio nonstd sosa)(modules vm_tester)) +(executable (name service_composer) (libraries unix genspio nonstd sosa)(modules service_composer)) +(executable (name multigit) (libraries unix genspio nonstd sosa)(modules multigit)) +(executable (name small) (libraries genspio nonstd sosa)(modules small)) +(rule (targets small_examples.ml)(deps small.exe)(action (progn +(run ./small.exe small_examples.ml)))) +(executable (name small_examples) (libraries genspio tests nonstd sosa)(modules small_examples)) diff --git a/src/examples/multigit.ml b/src/examples/multigit.ml index 910657f..627324b 100644 --- a/src/examples/multigit.ml +++ b/src/examples/multigit.ml @@ -3,7 +3,7 @@ A simple way to generate and install the scripts is: genspio_multigit=_build/default/src/examples/multigit.exe - jbuilder build $genspio_multigit + dune build $genspio_multigit $genspio_multigit $BINNPATH *) @@ -11,7 +11,6 @@ open Nonstd module String = Sosa.Native_string let ( // ) = Filename.concat - let msg fmt = ksprintf (eprintf "%s\n%!") fmt (*md We rename the EDSL locally to, e.g., be able to add functions. *) @@ -26,11 +25,9 @@ module Git_config = struct let paths_option = "multi-git.paths" let paths_help () = - [ "Default paths to explore can be set in Git's configuration:" - ; "" + [ "Default paths to explore can be set in Git's configuration:"; "" ; " git config --global --add multi-git.paths /path/to/repos1" - ; " git config --global --add multi-git.paths /path/to/repos2" - ; "" ] + ; " git config --global --add multi-git.paths /path/to/repos2"; "" ] let all_paths () = let open Gedsl in @@ -56,8 +53,7 @@ module Repository = struct | None -> exec ["git"; "remote"; "-v"] | Some s -> call (strs ["git"; "remote"; "get-url"] @ [s]) ) ||> exec ["grep"; g] )) - [printf (str o) []] - in + [printf (str o) []] in switch [ remote_greps "gpg_remote" "GGPG" ; remote_greps "github.com" "GHub" @@ -75,7 +71,6 @@ let version_string = module Multi_status = struct include Gedsl.Script_with_describe (struct let name = "git-multi-status" - let description = "Show the status of a bunch of Git repositories" end) @@ -84,11 +79,9 @@ module Multi_status = struct ; sprintf "Description: “%s”" description ] let extra_help () = - [ "" - ; "Use `git multi-status /path/to/repos1 /path/to/repos2` to display" + [ ""; "Use `git multi-status /path/to/repos1 /path/to/repos2` to display" ; "a compact report of all the git repositories found in the folders " - ; "`/path/to/repos1` and `/path/to/repos2`." - ; "" ] + ; "`/path/to/repos1` and `/path/to/repos2`."; "" ] @ Git_config.paths_help () module Git = struct @@ -103,7 +96,7 @@ module Multi_status = struct exec ( ["git"; "branch"; "-vv"] @ Option.value_map not_merged_in ~default:[] ~f:(fun br -> - ["--no-merged"; br] ) ) + ["--no-merged"; br]) ) ||> exec ["grep"; "-v"; "\\["] (*md @@ -121,8 +114,7 @@ Pretty cool, right: let wrap_string_hack ~columns ~first_line_indent ~other_lines_indent ~final_newline str_value = call - [ str "git" - ; str "log" + [ str "git"; str "log" ; Str.concat_list [ ksprintf str "--pretty=format:%%w(%d,%d,%d)" columns first_line_indent other_lines_indent @@ -152,15 +144,12 @@ Pretty cool, right: ; ( "L/H" , list_local_branches ~not_merged_in:"HEAD" () , "Not-remote-tracking local branches not merged in `HEAD`" ) - (* git branch -vv --no-merged HEAD | grep -v '\[' *) - ] - in + (* git branch -vv --no-merged HEAD | grep -v '\[' *) + ] in List.map ~f:(fun (t, e, d) -> (t, get_count e, d)) counts let title (c, _, _) = c - let code (_, c, _) = c - let description (_, _, c) = c let top_row () = @@ -178,13 +167,12 @@ Pretty cool, right: let help () = let longest = List.map (all ()) ~f:(fun c -> title c |> String.length) - |> List.fold ~init:0 ~f:max - in + |> List.fold ~init:0 ~f:max in [sprintf "The table shows %d columns:" (List.length (all ())); ""] @ List.map (all ()) ~f:(fun c -> sprintf "* `%s`%s-> %s." (title c) (String.make (longest - (title c |> String.length)) ' ') - (description c) ) + (description c)) end let msgf fmt l = @@ -201,8 +189,7 @@ Pretty cool, right: ||> exec ["sed"; {sed|s/^\*\? *\([^ ]\+\).*$/\1/|sed}] ||> exec ["tr"; "\\n"; ","] ||> exec ["sed"; {|s/,$/./|}] - ||> exec ["sed"; {|s/,/, /g|}] - in + ||> exec ["sed"; {|s/,/, /g|}] in let total_width = 86 in let display_section ~show_modified ~show_ahead ~show_local ~show_all path = let topdir = tmp_file "topdir" in @@ -247,8 +234,7 @@ Pretty cool, right: ~final_newline:true @@ get_stdout (Git.list_local_branches () |> to_list_of_names) - ] ] ) ] - in + ] ]) ] in let open Command_line in let opts = let open Arg in @@ -263,18 +249,17 @@ Pretty cool, right: Git_config.paths_option) & flag ["--version"] ~doc:"Show version information." & describe_option_and_usage () - ~more_usage:(extra_help () @ [""] @ Columns.help ()) - in + ~more_usage:(extra_help () @ [""] @ Columns.help ()) in parse opts (fun ~anon - show_modified - show_ahead - show_local - show_all - no_config - version - describe - -> + show_modified + show_ahead + show_local + show_all + no_config + version + describe + -> let do_section = display_section ~show_modified ~show_ahead ~show_local ~show_all in @@ -282,13 +267,12 @@ Pretty cool, right: [ if_seq version ~t:[out (sprintf "%s: %s" name version_string) []] ~e: - [ setenv (str "PAGER") (str "cat") + [ setenv ~var:(str "PAGER") (str "cat") ; Elist.iter anon ~f:(fun p -> do_section (p ())) ; if_seq no_config ~t:[] ~e: [ Git_config.all_paths () - ||> on_stdin_lines (fun line -> do_section line) ] ] ] - ) + ||> on_stdin_lines (fun line -> do_section line) ] ] ]) end module Activity_report = struct @@ -308,9 +292,7 @@ module Activity_report = struct ; "Use `git activity-report --since 2018-10-31 /path/to/repos1 \ /path/to/repos2` to display" ; "a detailed “recent happenings” report of all the git repositories \ - found" - ; "in the folders `/path/to/repos1` and `/path/to/repos2`." - ; "" ] + found"; "in the folders `/path/to/repos1` and `/path/to/repos2`."; "" ] @ Git_config.paths_help () let script () = @@ -338,8 +320,7 @@ module Activity_report = struct & flag ["--fetch"] ~doc:(sprintf "Run `git fetch --all` before showing a repository.") & flag ["--version"] ~doc:"Show version information." - & describe_option_and_usage () ~more_usage:(extra_help ()) - in + & describe_option_and_usage () ~more_usage:(extra_help ()) in let out f l = printf (ksprintf str "%s\n" f) l in let repo_name p = call [str "basename"; p] |> get_stdout_one_line in let display_section ~section_base ~since ~fetch_before path = @@ -351,8 +332,7 @@ module Activity_report = struct ||> on_stdin_lines (fun line -> let since_opt = Str.concat_list [str "--since="; since] in let git_log l = - call (strs ["git"; "--no-pager"; "log"] @ l) - in + call (strs ["git"; "--no-pager"; "log"] @ l) in let commit_number l = git_log ([since_opt; str "--oneline"] @ l) |> get_count in @@ -361,8 +341,7 @@ module Activity_report = struct ( [since_opt] @ strs ["--reverse"; "--pretty=tformat:- %s. %n %b"] @ [branch] ) - ||> exec ["grep"; "-Ev"; "^ *$"] - in + ||> exec ["grep"; "-Ev"; "^ *$"] in let fence () = out (String.make 80 '`') [] in seq [ call [str "cd"; topdir#get] @@ -377,27 +356,20 @@ module Activity_report = struct Str.(commit_number [] <$> str "0") ~t: [ out "\\n%s# %s: %s\\n" - [ section_base - ; Repository.get_kind () + [ section_base; Repository.get_kind () ; repo_name line ] ; out "\\nWorking tree:\\n" [] ; fence () ; exec - [ "git" - ; "status" - ; "--short" - ; "--branch" + [ "git"; "status"; "--short"; "--branch" ; "--show-stash" ] - ; fence () - ; out "\\nGraph:\\n" [] - ; fence () + ; fence (); out "\\nGraph:\\n" []; fence () ; git_log ( [since_opt] @ strs - [ "--graph" - ; "--decorate" - ; "--pretty=tformat:%w(72,0,2)%d %s" - ; "--all" ] ) + [ "--graph"; "--decorate" + ; "--pretty=tformat:%w(72,0,2)%d %s"; "--all" + ] ) ; fence () ; git_log ( [since_opt] @@ -414,8 +386,7 @@ module Activity_report = struct (get_stdout_one_line ( line >> exec ["sed"; "s/[ ,].*$//"] - )) ] ) ] ] ) ] - in + )) ]) ] ]) ] in parse opts (fun ~anon no_config since section_base fetch_before version describe -> let tmp_since = tmp_file "gar-since" in @@ -432,34 +403,30 @@ module Activity_report = struct let today_nth = exec ["date"; "+%u"] in let last_sunday = call - [ str "date" - ; str "-d" + [ str "date"; str "-d" ; Str.concat_list - [ get_stdout_one_line today - ; str " -" + [ get_stdout_one_line today; str " -" ; get_stdout_one_line today_nth ; str " days" ] - ; str date_format ] - in + ; str date_format ] in [ eprintf (str "Last Sunday was %s.\\n") [get_stdout_one_line last_sunday] ; tmp_since#set (get_stdout_one_line last_sunday) ]) ; Elist.iter anon ~f:(fun p -> display_section ~section_base ~since:tmp_since#get - ~fetch_before (p ()) ) + ~fetch_before (p ())) ; if_seq no_config ~t:[] ~e: [ Git_config.all_paths () ||> on_stdin_lines (fun line -> display_section ~since:tmp_since#get - ~section_base ~fetch_before line ) ] ] ] ) + ~section_base ~fetch_before line) ] ] ]) end module Fetch_all = struct include Gedsl.Script_with_describe (struct let name = "git-fetch-all" - let description = "Call git fetch a bunch of Git repositories" end) @@ -468,11 +435,9 @@ module Fetch_all = struct ; sprintf "Description: “%s”" description ] let extra_help () = - [ "" - ; "Use `git fetch-all /path/to/repos1 /path/to/repos2` to run" + [ ""; "Use `git fetch-all /path/to/repos1 /path/to/repos2` to run" ; "`git fetch --all` in the folders `/path/to/repos1` and \ - `/path/to/repos2`." - ; "" ] + `/path/to/repos2`."; "" ] @ Git_config.paths_help () let script () = @@ -482,8 +447,7 @@ module Fetch_all = struct let fetch_remote errors_file repo line = let log = Str.concat_list - [str "/tmp/multi-fetch-"; repo; str "-"; line; str ".log"] - in + [str "/tmp/multi-fetch-"; repo; str "-"; line; str ".log"] in seq [ if_seq (succeeds @@ -525,8 +489,7 @@ module Fetch_all = struct [ ls_remotes ||> on_stdin_lines (fetch_remote errors_file repo) ] - ; printf (str "\\n") [] ] ) ] - in + ; printf (str "\\n") [] ]) ] in let open Command_line in let opts = let open Arg in @@ -535,8 +498,7 @@ module Fetch_all = struct (sprintf "Do not look at the `%s` git-config option." Git_config.paths_option) & flag ["--version"] ~doc:"Show version information." - & describe_option_and_usage () ~more_usage:(extra_help ()) - in + & describe_option_and_usage () ~more_usage:(extra_help ()) in parse opts (fun ~anon no_config version describe -> let errors = tmp_file "fetch-all-errors" in let go = fetch_in ~errors_file:errors in @@ -553,7 +515,7 @@ module Fetch_all = struct ; if_seq Str.(errors#get <$> str "") ~t:[out "\\n## Errors:" []; call [str "cat"; errors#path]] - ] ] ) + ] ]) end let cmdf fmt = @@ -561,7 +523,7 @@ let cmdf fmt = (fun s -> match Sys.command s with | 0 -> () - | other -> ksprintf failwith "CMD: %S failed with %d" s other ) + | other -> ksprintf failwith "CMD: %S failed with %d" s other) fmt module Meta_repository = struct @@ -577,23 +539,20 @@ module Meta_repository = struct assemble (String.length one) more ) else ( Buffer.add_string buf ((if col = 0 then "" else " ") ^ one) ; - assemble potential more ) - in + assemble potential more ) in let words = String.split s ~on:(`Character ' ') |> List.map ~f:String.strip - |> List.filter ~f:(( <> ) "") - in + |> List.filter ~f:(( <> ) "") in assemble 0 words ; Buffer.contents buf let cmd_to_string_list cmd = let i = Unix.open_process_in cmd in let rec loop acc = - try loop (input_line i :: acc) with _ -> close_in i ; List.rev acc - in + try loop (input_line i :: acc) with _ -> close_in i ; List.rev acc in loop [] - let readme_md ~path ~output = + let readme_md ~path:_ ~output = let o = open_out output in let open Format in let fmt = formatter_of_out_channel o in @@ -608,11 +567,9 @@ module Meta_repository = struct ksprintf (fun s -> let lines = - cmd_output (s ^ " | grep -E -v '^usage:' | sed 's/->/→/'") - in - out "%s\n" lines ; out "\n\n" ; out "See also `%s`.\n\n" s ) - fmt - in + cmd_output (s ^ " | grep -E -v '^usage:' | sed 's/->/→/'") in + out "%s\n" lines ; out "\n\n" ; out "See also `%s`.\n\n" s) + fmt in title "Git: Multi-Repository" ; par "This project provides a couple of scripts which handle multiple Git \ @@ -622,8 +579,7 @@ module Meta_repository = struct par "The scripts provided as of now are:" ; let describe s = let lines = cmd_output (s ^ " --describe") in - out "- `%s`: %s.\n" s lines - in + out "- `%s`: %s.\n" s lines in describe "git-multi-status" ; describe "git-activity-report" ; describe "git-fetch-all" ; @@ -667,8 +623,7 @@ module Meta_repository = struct let git_repos_smondet = git_repos_top // "smondet" in let git_repos_bitbucket = git_repos_top // "bitbucket" in let all_git_repo_tops = - [git_repos_hammerlab; git_repos_smondet; git_repos_bitbucket] - in + [git_repos_hammerlab; git_repos_smondet; git_repos_bitbucket] in let hammerlabs = ["ketrew"; "biokepi"; "genspio"; "coclobas"] in let smondets = ["genspio-doc"; "vecosek"] in let example_cmd ?(wrap_display = true) ?(with_fence = `Yes) @@ -678,8 +633,7 @@ module Meta_repository = struct let lines = cmd_lines s in let w = if wrap_display then wrap ~newline:" \\\n" ~indent:6 ~columns:70 - else fun e -> e - in + else fun e -> e in out " $ %s\n" (w s) ; if lines <> [] || ignore_output then let fence = String.make 72 '`' in @@ -690,9 +644,8 @@ module Meta_repository = struct out "%s\n\n" fence | `Quote -> out "\n" ; - List.iter lines ~f:(out "> %s\n") ) - f - in + List.iter lines ~f:(out "> %s\n")) + f in par "Let's see a sequence of examples to demo the scripts. First, we \ prepare a set of *“test”* repositories in `%s`:" @@ -701,8 +654,7 @@ module Meta_repository = struct List.iter all_git_repo_tops ~f:(example_cmd "mkdir -p %s") ; let clone repos uri_prefix path = List.iter repos ~f:(fun r -> - example_cmd "git clone %s%s.git %s/%s" uri_prefix r path r ) - in + example_cmd "git clone %s%s.git %s/%s" uri_prefix r path r) in clone hammerlabs "https://github.com/hammerlab/" git_repos_hammerlab ; clone smondets "https://gitlab.com/smondet/" git_repos_smondet ; clone ["nonstd"] "https://bitbucket.org/smondet/" git_repos_bitbucket ; @@ -713,8 +665,7 @@ module Meta_repository = struct to get consistent output w.r.t. users' configuration):" ; let on_all f cmd = ksprintf f "%s --no-config %s" cmd - (String.concat ~sep:" " all_git_repo_tops) - in + (String.concat ~sep:" " all_git_repo_tops) in on_all (example_cmd "%s") "git multi-status" ; par "" ; par @@ -798,8 +749,7 @@ let () = let repomode = try Sys.getenv "repomode" = "true" with _ -> false in let output filename script long_description = let gms = - if repomode then path // "bin" // filename else path // filename - in + if repomode then path // "bin" // filename else path // filename in msg "Outputting %S" gms ; cmdf "mkdir -p %s" Filename.(quote (dirname gms)) ; let o = open_out gms in @@ -809,16 +759,15 @@ let () = "#!/bin/sh\n\n%s\n\n%a\n" ( long_description () @ [ "The following is generated by an OCaml program using the \ - Genspio EDSL." - ; "See ." ] + Genspio EDSL."; "See ." + ] |> List.map ~f:(sprintf "# %s") |> String.concat ~sep:"\n" ) Genspio.Compile.To_slow_flow.Script.pp_posix (Genspio.Compile.To_slow_flow.compile (script () |> Genspio.Transform.Constant_propagation.process))) ; close_out o ; - cmdf "chmod +x %s" (Filename.quote gms) - in + cmdf "chmod +x %s" (Filename.quote gms) in Multi_status.(output name script long_description) ; Activity_report.(output name script long_description) ; Fetch_all.(output name script long_description) ; diff --git a/src/examples/service_composer.ml b/src/examples/service_composer.ml index b20775c..69aeee7 100644 --- a/src/examples/service_composer.ml +++ b/src/examples/service_composer.ml @@ -5,7 +5,7 @@ modules. A simple way to generate and install the scripts is: genspio_service_composer=_build/default/src/examples/service_composer.exe - jbuilder build $genspio_service_composer + dune build $genspio_service_composer $genspio_service_composer --name cosc --output-path $BINNPATH The `cosc*` scripts will be installed and ready to use in `$BINPATH` @@ -41,7 +41,6 @@ open Nonstd module String = Sosa.Native_string let ( // ) = Filename.concat - let msg fmt = ksprintf (eprintf "%s\n%!") fmt module Gedsl = Genspio.EDSL @@ -51,7 +50,7 @@ let cmdf fmt = (fun s -> match Sys.command s with | 0 -> () - | other -> ksprintf failwith "CMD: %S failed with %d" s other ) + | other -> ksprintf failwith "CMD: %S failed with %d" s other) fmt module Version = struct @@ -59,20 +58,11 @@ module Version = struct lazy Unix.( gettimeofday () |> gmtime - |> fun { tm_sec - ; tm_min - ; tm_hour - ; tm_mday - ; tm_mon - ; tm_year - ; tm_wday - ; tm_yday - ; tm_isdst } -> + |> fun {tm_sec; tm_min; tm_hour; tm_mday; tm_mon; tm_year; _} -> sprintf "%4d%02d%02d.%02d%02d%02d" (1900 + tm_year) (1 + tm_mon) tm_mday tm_hour tm_min tm_sec) let get () = Lazy.force version - let str () = Gedsl.str (get ()) end @@ -105,8 +95,7 @@ The function `write` is the only real I/O of this whole OCaml program. *) let write ?(compiler = `Slow_flow) t ~output_path ~root = let path = - output_path // String.concat ~sep:"-" (root :: t.relative_path) - in + output_path // String.concat ~sep:"-" (root :: t.relative_path) in let o = open_out path in msg "Outputting “%s” to %s\n%!" t.description path ; ( match compiler with @@ -219,8 +208,7 @@ to output a stronger hash. let open Gedsl in let env_var v default = say " * `%s`, value: '%s' (default: %s)" - [str (v t); getenv (str (v t)); str default] - in + [str (v t); getenv (str (v t)); str default] in seq [ say "Environment variables: " [] (* ; env_var var_screen_name t.default_screen_name *) @@ -241,19 +229,12 @@ module Manual = struct | Extended of {yes: item list; no: item list} let _global_ : item list ref = ref [] - let add l = _global_ := !_global_ @ l - let raw s = Raw s - let from f = [Root_env f] - let extended ?(no = []) yes = [Extended {yes; no}] - let raws l = List.map l ~f:raw - let title s = raws [s; String.make (String.length s) '='; ""] - let section s = raws [s; String.make (String.length s) '-'; ""] let wrap ?(indent = 0) ?(columns = 72) s = @@ -268,17 +249,14 @@ module Manual = struct assemble (String.length one) more ) else ( Buffer.add_string buf ((if col = 0 then "" else " ") ^ one) ; - assemble potential more ) - in + assemble potential more ) in let words = String.split s ~on:(`Character ' ') |> List.map ~f:String.strip - |> List.filter ~f:(( <> ) "") - in + |> List.filter ~f:(( <> ) "") in assemble 0 words ; Buffer.contents buf let par s = raws [wrap s; ""] - let code_block s = raws (["```"] @ s @ ["```"; ""]) let list l = @@ -296,9 +274,8 @@ module Manual = struct let () = add - @@ from (fun ~root env -> - ksprintf title "%s: Compose Processes With Screen" (pre_title root) - ) + @@ from (fun ~root _ -> + ksprintf title "%s: Compose Processes With Screen" (pre_title root)) @ from (fun ~root env -> ksprintf par "The `%s*` scripts are a family of POSIX shell executables that \ @@ -326,10 +303,10 @@ module Manual = struct of the configuration path (`%s`). This can be useful to build \ custom/project-specific scripts that can remain independent \ from each other without setting an environment variable." - root env.Environment.default_configuration_path ) + root env.Environment.default_configuration_path) @ extended ( section "Installation" - @ from (fun ~root env -> + @ from (fun ~root _ -> ksprintf par "Simply copy `%s*` to somewhere in your `$PATH`, the scripts \ depend on a reasonably valid version of `/bin/sh` and GNU \ @@ -337,16 +314,15 @@ module Manual = struct root @ ksprintf par "If you are using the code-generator, you can just point \ - the `--output-path` option at the right directory." ) ) + the `--output-path` option at the right directory.") ) @ section "Usage" - @ from (fun ~root env -> + @ from (fun ~root _ -> let intro fmt = ksprintf (ksprintf par "The basic manual is obtained from the `%s man` command.%s" root) - fmt - in + fmt in extended (intro " The, present, “`README.md`” version is the result of \ @@ -356,9 +332,9 @@ module Manual = struct @ ksprintf par "Then, see `%s --help` first, or for any sub-command try \ `%s  --help`." - root root ) + root root) @ section "Screen Session Isolation" - @ from (fun ~root env -> + @ from (fun ~root _ -> ksprintf par "`%s` isolates Screen sessions by using their session name." root @ ksprintf par @@ -376,10 +352,10 @@ module Manual = struct will generate a name, which is function of the root path and \ generation parameters and tries to ensure that the session is \ unique on the host." - root ) + root) @ extended ( section "Docker Image For the Generator" - @ from (fun ~root env -> + @ from (fun ~root:_ _ -> let image = "smondet/genspio-doc-dockerfiles:apps406" in ksprintf par "If you have [`opam`](https://opam.ocaml.org), setting up the \ @@ -389,7 +365,7 @@ module Manual = struct image @ code_block [ sprintf "docker run -it %s genspio-service-composer --help" - image ] ) ) + image ]) ) let output ~root ~env extended = let open Gedsl in @@ -462,9 +438,7 @@ module Job = struct call [str "cat"; pid] |> get_stdout_one_line let ps env name ~o = call [str "ps"; str "-q"; get_pid env name; str "-o"; o] - let ps_stat_exec env name = ps env name ~o:(str "stat=") - let ps_stat env name = ps_stat_exec env name |> get_stdout_one_line let ps_stat_or_fail env name = @@ -475,7 +449,6 @@ module Job = struct (seq [printf (str "None") []; exit 2]) let ps_cpu env name = ps ~o:(str "cpu=") env name |> get_stdout_one_line - let is_running env name = succeeds_silently (ps_stat_or_fail env name) let run_script env name = @@ -495,19 +468,15 @@ module Job = struct ~e: [ printf (str "{ sh %s 2>&1 ; } | tee -a %s\\n") - [job_path env name; log_path env name] ] ]) ] - in + [job_path env name; log_path env name] ] ]) ] in (mk, runner) let delete env name = let rm p = verbose_call ~prefix:" -> " [str "rm"; str "-f"; p] in seq (List.map ~f:rm - [ job_path env name - ; log_path env name - ; pid_path env name - ; run_path env name - ; Options.path env name ]) + [ job_path env name; log_path env name; pid_path env name + ; run_path env name; Options.path env name ]) end (*md The `Screen` module contains Genspio expressions to manipulate a @@ -521,7 +490,6 @@ module Screen = struct open Gedsl let ls env = call [str "screen"; str "-ls"; Environment.screen_name env] - let is_on env = ls env |> succeeds_silently let call ?verbose env l = @@ -546,7 +514,6 @@ All the `*_script` modules define one actual script to be generated. *) module Configuration_script = struct let description = "Manage the configuration." - let name = "configuration" let make () = @@ -558,14 +525,12 @@ module Configuration_script = struct ; (str "rmjob", str "removejob") ; (str "init", str "initialize") ] ~name:(sprintf "%s-%s" root name) - ~description () ) + ~description ()) end module Manual_script = struct include Gedsl.Script_with_describe (struct - let name = "manual" - - let description = "Show the manual." + let name = "manual" let description = "Show the manual." end) let make ~env () = @@ -576,48 +541,41 @@ module Manual_script = struct let open Arg in flag ["--extended"; "-X"] ~doc:"Provide extra information." & flag ["--no-pager"] ~doc:"Do not use a pager." - & describe_option_and_usage () - in - parse opts (fun ~anon extended no_pager describe -> + & describe_option_and_usage () in + parse opts (fun ~anon:_ extended no_pager describe -> deal_with_describe describe - [Manual.output ~root ~env extended ||> pager ~disable:no_pager ()] - ) ) + [Manual.output ~root ~env extended ||> pager ~disable:no_pager ()])) end module Version_script = struct include Gedsl.Script_with_describe (struct - let name = "version" - - let description = "Show the version information." + let name = "version" let description = "Show the version information." end) - let make ~env () = + let make ~env:_ () = Script.make [name] ~description (fun ~root -> let open Gedsl in let open Command_line in let opts = let open Arg in flag ["--extended"; "-X"] ~doc:"Provide extra information" - & describe_option_and_usage () - in - parse opts (fun ~anon extended describe -> + & describe_option_and_usage () in + parse opts (fun ~anon:_ extended describe -> deal_with_describe describe [ if_seq extended ~t: [ say "%s %s (Genspio %s)" [str root; Version.str (); str Genspio.Meta.version] ] - ~e:[say "%s" [Version.str ()]] ] ) ) + ~e:[say "%s" [Version.str ()]] ])) end module Init_script = struct include Gedsl.Script_with_describe (struct - let name = "initialize" - - let description = "Initialize the configuration." + let name = "initialize" let description = "Initialize the configuration." end) let make ~env () = - Script.make ["configuration"; name] ~description (fun ~root -> + Script.make ["configuration"; name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let opts = @@ -629,22 +587,19 @@ module Init_script = struct "Set the screen session name (the default is a function of \ the root path and other constants of the script)") ~default:(Environment.make_default_screen_name env) - & describe_option_and_usage () - in - parse opts (fun ~anon screen_name describe -> + & describe_option_and_usage () in + parse opts (fun ~anon:_ screen_name describe -> deal_with_describe describe - [Environment.init ~screen_name env; say "Done." []] ) ) + [Environment.init ~screen_name env; say "Done." []])) end module Add_job_script = struct include Gedsl.Script_with_describe (struct - let name = "addjob" - - let description = "Add a job to the configuration." + let name = "addjob" let description = "Add a job to the configuration." end) let make ~env () = - Script.make ["configuration"; name] ~description (fun ~root -> + Script.make ["configuration"; name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let default_none = str "--none--" in @@ -658,9 +613,9 @@ module Add_job_script = struct ~doc: "Don't save logs (useful for commands that grab the terminal \ like `top`)" - & describe_option_and_usage () - in - parse opts (fun ~anon name shell_command interpreter no_log describe -> + & describe_option_and_usage () in + parse opts + (fun ~anon:_ name shell_command interpreter no_log describe -> let jpath = Job.job_path env name in deal_with_describe describe [ if_then @@ -678,24 +633,20 @@ module Add_job_script = struct ; str " '" >> exec ["cat"] ; shell_command >> exec ["sed"; "s/'/'\\\\''/g"] ; str "'\n" >> exec ["cat"] ]) - ; say "Done." [] ] ) ) + ; say "Done." [] ])) end module Remove_job_script = struct include Gedsl.Script_with_describe (struct let name = "removejob" - let description = "Remove one or more jobs from the configuration." end) let make ~env () = - Script.make ["configuration"; name] ~description (fun ~root -> + Script.make ["configuration"; name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in - let opts = - let open Arg in - describe_option_and_usage () - in + let opts = describe_option_and_usage () in parse opts (fun ~anon describe -> deal_with_describe describe [ Elist.iter anon ~f:(fun name -> @@ -706,19 +657,17 @@ module Remove_job_script = struct [ say "Removing %s..." [name ()] ; Job.delete env (name ()) ] ~e:[say "Job %s does not seem to exist..." [name ()]]) - ] ) - ; say "Done." [] ] ) ) + ]) + ; say "Done." [] ])) end module Start_script = struct include Gedsl.Script_with_describe (struct - let name = "start" - - let description = "Start all or a given list of jobs." + let name = "start" let description = "Start all or a given list of jobs." end) let make ~env () = - Script.make [name] ~description (fun ~root -> + Script.make [name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let opts = @@ -743,14 +692,9 @@ module Start_script = struct [ say "* Starting '%s' in Screen window: '%s'" [name; Screen.window_name name] ; Screen.call env - [ str "-X" - ; str "screen" - ; str "-t" - ; Screen.window_name name - ; str "sh" - ; runpath ] ] - ~e:[say "* Job '%s' is not configured!" [name]] ]) - in + [ str "-X"; str "screen"; str "-t" + ; Screen.window_name name; str "sh"; runpath ] ] + ~e:[say "* Job '%s' is not configured!" [name]] ]) in parse opts (fun ~anon all describe -> deal_with_describe describe [ Screen.ensure_running env @@ -760,31 +704,26 @@ module Start_script = struct [Environment.configuration_path env] ; Environment.on_jobs env (fun path -> let name = Job.name path in - start_one name ) ] + start_one name) ] ~e: [ Elist.iter anon ~f:(fun item -> let name = item () in - seq [say "Starting job '%s':" [name]; start_one name] - ) ] - ; say "Done." [] ] ) ) + seq [say "Starting job '%s':" [name]; start_one name]) + ] + ; say "Done." [] ])) end module Configuration_display_script = struct include Gedsl.Script_with_describe (struct - let name = "display" - - let description = "Show the configuration." + let name = "display" let description = "Show the configuration." end) let make ~env () = - Script.make ["configuration"; name] ~description (fun ~root -> + Script.make ["configuration"; name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in - let opts = - let open Arg in - describe_option_and_usage () - in - parse opts (fun ~anon describe -> + let opts = describe_option_and_usage () in + parse opts (fun ~anon:_ describe -> let path = Environment.configuration_path env in deal_with_describe describe [ say "Configuration path: %s" [path] @@ -796,33 +735,27 @@ module Configuration_display_script = struct (str "Job: '%s'\\n |-> Command: [%s]\\n |-> \ Options: %s\\n") - [ Job.name path - ; Job.command path + [ Job.name path; Job.command path ; call [ str "cat" ; Job.Options.path env (Job.name path) ] ||> exec ["tr"; "\\n"; ","] - |> get_stdout ] ) ] + |> get_stdout ]) ] ~e:[say "Configuration is empty (not even a directory)" []] - ] ) ) + ])) end module Configuration_destroy_script = struct include Gedsl.Script_with_describe (struct - let name = "destroy" - - let description = "Destroy the configuration." + let name = "destroy" let description = "Destroy the configuration." end) let make ~env () = - Script.make ["configuration"; name] ~description (fun ~root -> + Script.make ["configuration"; name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in - let opts = - let open Arg in - describe_option_and_usage () - in - parse opts (fun ~anon describe -> + let opts = describe_option_and_usage () in + parse opts (fun ~anon:_ describe -> let path = Environment.configuration_path env in deal_with_describe describe [ say "Configuration path: %s" [path] @@ -830,14 +763,12 @@ module Configuration_destroy_script = struct ~t:[verbose_call [str "rm"; str "-fr"; path]] ~e: [ say "Configuration is not even a directory: %s" [path] - ; fail "FAILURE" ] ] ) ) + ; fail "FAILURE" ] ])) end module Attach_script = struct include Gedsl.Script_with_describe (struct - let name = "attach" - - let description = "Attach to the Screen being managed." + let name = "attach" let description = "Attach to the Screen being managed." end) let go env create = @@ -857,34 +788,31 @@ module Attach_script = struct ; fail "STOPPING" ] ] ] let make ~env () = - Script.make [name] ~description (fun ~root -> + Script.make [name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let opts = let open Arg in flag ["--create"] ~doc:"Create if it doesn't exist." - & describe_option_and_usage () - in - parse opts (fun ~anon create describe -> - deal_with_describe describe [go env create] ) ) + & describe_option_and_usage () in + parse opts (fun ~anon:_ create describe -> + deal_with_describe describe [go env create])) end module Kill_script = struct include Gedsl.Script_with_describe (struct let name = "kill" - let description = "Kill Jobs or the whole Screen session (-a)." end) let make ~env () = - Script.make [name] ~description (fun ~root -> + Script.make [name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let opts = let open Arg in flag ["--all"; "-a"] ~doc:"Kill everything, incl. the Screen session" - & describe_option_and_usage () - in + & describe_option_and_usage () in let kills = tmp_file "kill-list" in parse opts (fun ~anon kill_em_all describe -> deal_with_describe describe @@ -897,37 +825,32 @@ module Kill_script = struct [ say "## Processing %s" [item ()] ; if_seq ( Screen.call env - [ str "-Q" - ; str "-p" + [ str "-Q"; str "-p" ; Screen.window_name (item ()) - ; str "-X" - ; str "info" ] + ; str "-X"; str "info" ] |> succeeds_silently ) ~t: [ say "-> Window found, killing now." [] ; Screen.call env [ str "-p" ; Screen.window_name (item ()) - ; str "-X" - ; str "kill" ] + ; str "-X"; str "kill" ] ; kills#set (str "yes") ] ~e: [ say "-> Window for job '%s' not found!" - [item ()] ] ] ) + [item ()] ] ]) ; if_seq Str.(kills#get =$= str "") - ~t:[say "Nothing was killed …" []] ] ] ) ) + ~t:[say "Nothing was killed …" []] ] ])) end module Logs_script = struct include Gedsl.Script_with_describe (struct - let name = "logs" - - let description = "Show logs for one or more jobs." + let name = "logs" let description = "Show logs for one or more jobs." end) let make ~env () = - Script.make [name] ~description (fun ~root -> + Script.make [name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let opts = @@ -936,27 +859,20 @@ module Logs_script = struct & flag ["--screen"] ~doc: "Get the screen window dump instead of the (potential) log file" - & describe_option_and_usage () - in + & describe_option_and_usage () in let cat_file job lp = if_seq (file_exists lp) ~t:[call [str "cat"; lp]] - ~e:[say "No logs available for %s" [job]] - in + ~e:[say "No logs available for %s" [job]] in let screen_file job show_path = let tmp = tmp_file "screen-dump" in seq [ Screen.call env - [ str "-p" - ; Screen.window_name job - ; str "-X" - ; str "hardcopy" - ; str "-h" - ; tmp#path ] + [ str "-p"; Screen.window_name job; str "-X"; str "hardcopy" + ; str "-h"; tmp#path ] ; if_seq show_path ~t:[printf (str "%s\\n") [tmp#path]] - ~e:[cat_file job tmp#path] ] - in + ~e:[cat_file job tmp#path] ] in parse opts (fun ~anon just_path screen describe -> deal_with_describe describe [ Elist.iter anon ~f:(fun name -> @@ -975,26 +891,24 @@ module Logs_script = struct "Job %s is configured to have no \ logs, try --screen" [job] ] - ~e:[cat_file job lp] ] ] ) ] ) ) + ~e:[cat_file job lp] ] ]) ])) end module Status_script = struct include Gedsl.Script_with_describe (struct let name = "status" - let description = "Get the status(es) of the processes." end) let make ~env () = - Script.make [name] ~description (fun ~root -> + Script.make [name] ~description (fun ~root:_ -> let open Gedsl in let open Command_line in let opts = let open Arg in flag ["--short"; "-s"] ~doc:"Don't output a ton of info" - & describe_option_and_usage () - in - parse opts (fun ~anon short describe -> + & describe_option_and_usage () in + parse opts (fun ~anon:_ short describe -> let prefix_output = exec ["sed"; "s/^/ | /"] in deal_with_describe describe [ if_seq (Screen.is_on env) @@ -1013,22 +927,18 @@ module Status_script = struct if_seq (Job.is_running env job) ~t: [ say "Job `%s`: PID: %s, CPU: %s, STAT: %s" - [ job - ; Job.get_pid env job - ; Job.ps_cpu env job + [ job; Job.get_pid env job; Job.ps_cpu env job ; Job.ps_stat env job ] ; if_then (not short) ( call - [ str "ps" - ; str "f" - ; str "-g" + [ str "ps"; str "f"; str "-g" ; Job.get_pid env job ] ||> prefix_output ) ] ~e: [ say "Job `%s` is not running (stat: %s)" [ job ; Job.ps_stat_or_fail env job - |> get_stdout_one_line ] ] ) ] ) ) + |> get_stdout_one_line ] ]) ])) end module Example_script = struct @@ -1053,13 +963,9 @@ module Example_script = struct ; cmt "Show the updated configuration:" ; call "config show" ; cmt "Show the current status:" - ; call "status" - ; cmt "Start everything:" - ; call "start --all" + ; call "status"; cmt "Start everything:"; call "start --all" ; cmt "Show the updated status:" - ; call "status" - ; cmt "Stop everything:" - ; call "kill --all" + ; call "status"; cmt "Stop everything:"; call "kill --all" ; cmt "Show the updated (short) status:" ; call "status --short" ; cmt "Destroy the configuration:" @@ -1069,8 +975,7 @@ module Example_script = struct let prefix = "#####" in let add_prefix pre s = String.split ~on:(`Character '\n') s - |> String.concat ~sep:(sprintf "\n%s" pre) - in + |> String.concat ~sep:(sprintf "\n%s" pre) in let prefix_indent = prefix ^ " " in List.concat_map l ~f:(function | s when String.strip s |> String.is_prefix ~prefix:"#" -> @@ -1081,13 +986,11 @@ module Example_script = struct | s -> [ sprintf "printf '%s >> %%s\\n' %s" prefix (Filename.quote (add_prefix prefix_indent s)) - ; s ] ) + ; s ]) |> String.concat ~sep:"\n" include Gedsl.Script_with_describe (struct - let name = "example" - - let description = "Show or run a full example." + let name = "example" let description = "Show or run a full example." end) let make ~env () = @@ -1102,37 +1005,33 @@ module Example_script = struct ~doc: (sprintf "Choose the example (default: %S)." default_example) ~default:(str default_example) - & describe_option_and_usage () - in + & describe_option_and_usage () in let run_or_show run example = let do_run () = let tmp = tmp_file "example-script" in seq [ tmp#set (to_script example |> str) ; say "Running as %s" [tmp#path] - ; call [str "sh"; tmp#path] ] - in + ; call [str "sh"; tmp#path] ] in if_seq run ~t:[do_run ()] ~e: [ printf (str "Example:\\n\\n") [] ; seq (List.map example ~f:(fun s -> - printf (str " %s\\n") [str s] )) ] - in - parse opts (fun ~anon run example describe -> + printf (str " %s\\n") [str s])) ] in + parse opts (fun ~anon:_ run example describe -> deal_with_describe describe [ switch ( List.map [basic env root] ~f:(fun (n, cl) -> - case Str.(example =$= str n) [run_or_show run cl] ) + case Str.(example =$= str n) [run_or_show run cl]) @ [ default [say "Unknown example: %s" [example]; fail "Stopping"] - ] ) ] ) ) + ] ) ])) let () = let first_sentence = "The distribution comes with runnable examples, try \ - `cosc example --help`." - in + `cosc example --help`." in Manual.( add ( section "Examples" @@ -1152,7 +1051,7 @@ module Base_script = struct ~aliases: Gedsl. [(str "config", str "configuration"); (str "man", str "manual")] - ~name:root ~description () ) + ~name:root ~description ()) end let () = @@ -1186,15 +1085,12 @@ let make ?default_configuration_path ?default_screen_name ~name ~output_path () ; Add_job_script.make ~env () ; Init_script.make ~env () ; Remove_job_script.make ~env () - ; Start_script.make ~env () - ; Logs_script.make ~env () - ; Attach_script.make ~env () - ; Kill_script.make ~env () + ; Start_script.make ~env (); Logs_script.make ~env () + ; Attach_script.make ~env (); Kill_script.make ~env () ; Manual_script.make ~env () ; Version_script.make ~env () ; Example_script.make ~env () - ; Status_script.make ~env () ] - in + ; Status_script.make ~env () ] in cmdf "mkdir -p %s" output_path ; List.iter scripts ~f:(Script.write ~output_path ~root:name) ; msg "Done." @@ -1226,8 +1122,7 @@ let () = , sprintf " Output the manual to a `README.md`." ) ; ( "--output-path" , Arg.String (fun s -> output_path := Some s) - , sprintf " Where to write the scripts." ) ] - in + , sprintf " Where to write the scripts." ) ] in Arg.parse args anon_fun usage ; List.iter !anon ~f:(msg "Ignoring %s") ; let die () = exit 2 in @@ -1235,12 +1130,12 @@ let () = | Some o -> o | None -> msg "Option `%s` is mandatory" opt ; - die () - in + die () in let output_path = need "--output-path" !output_path in let name = need "--name" !name in make ~name ?default_configuration_path:!config_path ?default_screen_name:!screen_name ~output_path () ; if !output_readme then ( msg "Outputting manual to %s/README.md" output_path ; - cmdf "%s/%s-manual --extended > %s/README.md" output_path name output_path ) + cmdf "%s/%s-manual --extended > %s/README.md" output_path name output_path + ) diff --git a/src/examples/small.ml b/src/examples/small.ml index ab4c47b..8a223ca 100644 --- a/src/examples/small.ml +++ b/src/examples/small.ml @@ -9,8 +9,7 @@ let example ?show name description code = "let () = examples := Example.make ~ocaml:%S %s %S %S %s :: !examples\n" code (match show with None -> "" | Some s -> sprintf "~show:%s" s) - name description code - in + name description code in examples := f :: !examples let intro_blob = @@ -55,7 +54,8 @@ Genspio.EDSL.( |ocaml} let () = - example "Call a command with Shell-Strings" ~show:"[`Stdout; `Pretty_printed]" + example "Call a command with Shell-Strings" + ~show:"[`Stdout; `Pretty_printed]" "The `call` construct is a more general version of `exec` that can take \ any EDSL string. As with `exec` the string will be checked for C-String \ compatibilty, hence the calls to `byte-array-to-c-string` in the \ diff --git a/src/examples/vm_tester.ml b/src/examples/vm_tester.ml index 756229a..3e138a9 100644 --- a/src/examples/vm_tester.ml +++ b/src/examples/vm_tester.ml @@ -14,14 +14,11 @@ module Shell_script = struct let m = String.map n ~f:(function | ('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-') as c -> c - | other -> '_' ) - in + | _ -> '_') in String.sub ~index:0 ~length:40 m |> Option.value ~default:m - let path {name; content} = - let hash = - Marshal.to_string content [] |> Digest.string |> Digest.to_hex - in + let path {name; content; _} = + let hash = Marshal.to_string content [] |> Digest.string |> Digest.to_hex in let tag = String.sub_exn ~index:0 hash ~length:8 in "_scripts" // sprintf "%s_%s.sh" (sanitize_name name) tag @@ -36,8 +33,7 @@ module Shell_script = struct (* dbg "name %s filename: %s" name filename; *) { files= ( filename - , [ "# Script %s" - ; "# Generated by Genspio" + , [ "# Script %s"; "# Generated by Genspio" ; sprintf "echo 'Genspio.Shell_script: %s (%s)'" name filename ; Genspio.Compile.to_many_lines content ] ) :: List.concat_map dep_scripts ~f:(fun c -> c.files) @@ -65,7 +61,6 @@ module Run_environment = struct List.map files ~f:(function Http (url, act) as t -> let base = local_file_name t in let wget = - let open Shell_script in let open Genspio.EDSL in check_sequence [ ("mkdir", exec ["mkdir"; "-p"; "_cache"]) @@ -78,18 +73,15 @@ module Run_environment = struct seq [ exec ["unxz"; "-k"; tmp_name_of_url t] ; exec - [ "mv" - ; "-f" + [ "mv"; "-f" ; Filename.chop_suffix (tmp_name_of_url t) ".xz" - ; base ] ] ) ] - in - (base, [], wget) ) + ; base ] ] ) ] in + (base, [], wget)) end module Ssh = struct let ssh_options = - [ "-oStrictHostKeyChecking=no" - ; "-oGlobalKnownHostsFile=/dev/null" + [ "-oStrictHostKeyChecking=no"; "-oGlobalKnownHostsFile=/dev/null" ; "-oUserKnownHostsFile=/dev/null" ] let host_file f = sprintf "root@localhost:%s" f @@ -116,9 +108,7 @@ module Run_environment = struct , exec ( sshpass ?password:root_password @@ ["ssh"] @ ssh_options - @ [ "-p" - ; Int.to_string ssh_port - ; "root@localhost" + @ [ "-p"; Int.to_string ssh_port; "root@localhost" ; sprintf "sh %s" tmp ] ) ) ] end @@ -137,7 +127,6 @@ module Run_environment = struct | Copy_relative of string * string let ssh_to_vm u = [Ssh_to_vm u] - let copy (`Relative src) (`Relative dst) = Copy_relative (src, dst) end @@ -156,38 +145,28 @@ module Run_environment = struct make (Qemu_arm {kernel; sd_card; machine; initrd; root_device}) let qemu_amd46 ?(ui = `No_graphic) ~hda = make (Qemu_amd46 {hda; ui}) - let http ?act uri = File.Http (uri, act) let start_qemu_vm : t -> Shell_script.t = function | { ssh_port - ; vm= Qemu_arm {kernel; machine; sd_card; root_device; initrd; _} } -> + ; vm= Qemu_arm {kernel; machine; sd_card; root_device; initrd; _} + ; _ } -> let open Shell_script in let open Genspio.EDSL in make "Start-qemu-arm" (exec - ( [ "qemu-system-arm" - ; "-M" - ; machine - ; "-m" - ; "1024M" - ; "-kernel" + ( [ "qemu-system-arm"; "-M"; machine; "-m"; "1024M"; "-kernel" ; File.local_file_name kernel ] @ Option.value_map initrd ~default:[] ~f:(fun f -> - ["-initrd"; File.local_file_name f] ) - @ [ "-pidfile" - ; "qemu.pid" - ; "-net" - ; "nic" - ; "-net" + ["-initrd"; File.local_file_name f]) + @ [ "-pidfile"; "qemu.pid"; "-net"; "nic"; "-net" ; sprintf "user,hostfwd=tcp::%d-:22" ssh_port - ; "-nographic" - ; "-sd" + ; "-nographic"; "-sd" ; File.local_file_name sd_card ; "-append" ; sprintf "console=ttyAMA0 verbose debug root=%s" root_device ] )) - | {ssh_port; vm= Qemu_amd46 {hda; ui}} -> + | {ssh_port; vm= Qemu_amd46 {hda; ui}; _} -> (* See https://wiki.qemu.org/Hosts/BSD qemu-system-x86_64 -m 2048 \ -hda FreeBSD-11.0-RELEASE-amd64.qcow2 -enable-kvm \ @@ -199,23 +178,17 @@ module Run_environment = struct (exec ( [ "qemu-system-x86_64" (* ; "-M" * ; machine *) - ; "-m" - ; "1024M" (* ; "-enable-kvm" → requires `sudo`?*) - ; "-hda" - ; File.local_file_name hda ] - @ [ "-pidfile" - ; "qemu.pid" - ; "-netdev" + ; "-m"; "1024M" (* ; "-enable-kvm" → requires `sudo`?*) + ; "-hda"; File.local_file_name hda ] + @ [ "-pidfile"; "qemu.pid"; "-netdev" ; sprintf "user,id=mynet0,hostfwd=tcp::%d-:22" ssh_port ; ( match ui with | `Curses -> "-curses" | `No_graphic -> "-nographic" ) - ; "-device" - ; "e1000,netdev=mynet0" ] )) + ; "-device"; "e1000,netdev=mynet0" ] )) let kill_qemu_vm : t -> Shell_script.t = function - | {name} -> - let open Shell_script in + | {name; _} -> let open Genspio.EDSL in let pid = get_stdout (exec ["cat"; "qemu.pid"]) in Shell_script.(make (sprintf "kill-qemu-%s" name)) @@ -240,8 +213,7 @@ module Run_environment = struct ~e:[printf (string "No PID file") []; exec ["false"]] ) ] let configure : t -> Shell_script.t = function - | {name; local_dependencies} -> - let open Shell_script in + | {name; local_dependencies; _} -> let open Genspio.EDSL in let report = tmp_file "configure-report.md" in let there_was_a_failure = tmp_file "bool-failure" in @@ -254,28 +226,27 @@ module Run_environment = struct ~t:[report#append (ksprintf str "* `%s`: found.\n" name)] ~e: [ report#append (ksprintf str "* `%s`: NOT FOUND!\n" name) - ; there_was_a_failure#set (bool true |> Bool.to_string) ] ) + ; there_was_a_failure#set (bool true |> Bool.to_string) ]) @ [ call [string "cat"; report#path] ; if_seq (there_was_a_failure#get |> Bool.of_string) ~t: [ exec ["printf"; "\\nThere were *failures* :(\\n"] ; exec ["false"] ] - ~e:[exec ["printf"; "\\n*Success!*\\n"]] ] - in + ~e:[exec ["printf"; "\\n*Success!*\\n"]] ] in Shell_script.(make (sprintf "configure-%s" name)) @@ check_sequence ~verbosity:`Output_all (List.mapi cmds ~f:(fun i c -> (sprintf "config-%s-%d" name i, c))) let make_dependencies = function - | {vm= Qemu_amd46 {hda}} -> File.make_files [hda] - | {vm= Qemu_arm {kernel; sd_card; initrd}} -> + | {vm= Qemu_amd46 {hda; _}; _} -> File.make_files [hda] + | {vm= Qemu_arm {kernel; sd_card; initrd; _}; _} -> File.make_files ( [kernel; sd_card] @ Option.value_map initrd ~default:[] ~f:(fun x -> [x]) ) let setup_dir_content tvm = - let {name; root_password; setup; ssh_port; vm} = tvm in + let {root_password; setup; ssh_port; _} = tvm in let other_files = ref [] in let dependencies = make_dependencies tvm in let start_deps = List.map dependencies ~f:(fun (base, _, _) -> base) in @@ -289,14 +260,12 @@ module Run_environment = struct doc ~default:"NOT DOCUMENTED") ; sprintf "%s: %s" target (String.concat ~sep:" " deps) ; sprintf "\t@%s" (Genspio.Compile.to_one_liner ~no_trap:true action) - ] - in + ] in let make_script_entry ?doc ?phony ?deps target script = let open Shell_script in let {files; call} = Shell_script.compile script in other_files := !other_files @ files ; - make_entry ?doc ?phony ?deps target call - in + make_entry ?doc ?phony ?deps target call in let setup_entries = List.mapi setup ~f:(fun idx -> let name = sprintf "setup-%d" idx in @@ -317,14 +286,13 @@ module Run_environment = struct @@ ["ssh"; "-p"; Int.to_string ssh_port] @ Ssh.ssh_options @ [ "root@localhost" - ; sprintf "tar -x -f - ; mv %s %s" src dst ] )) ) - ) + ; sprintf "tar -x -f - ; mv %s %s" src dst ] )) )) in let makefile = ["# Makefile genrated by Genspio's VM-Tester"] @ List.concat_map dependencies ~f:(fun (base, deps, cmd) -> Shell_script.(make (sprintf "get-%s" (sanitize_name base)) cmd) - |> make_script_entry ~deps base ) + |> make_script_entry ~deps base) @ make_script_entry ~phony:true "configure" (configure tvm) ~doc:"Configure this local-host (i.e. check for requirements)." @ make_script_entry ~deps:start_deps ~phony:true "start" @@ -347,8 +315,7 @@ module Run_environment = struct printf (ksprintf string "%s ssh -p %d %s root@localhost" prefix ssh_port (String.concat ~sep:" " Ssh.ssh_options)) - []) - in + []) in let help = make_script_entry ~phony:true "help" Shell_script.( @@ -361,9 +328,9 @@ module Run_environment = struct ; List.map ( ("help", Some "Display this help message") :: !help_entries ) ~f:(function - | target, None -> "" + | _, None -> "" | target, Some doc -> - sprintf "* `make %s`: %s\n" target doc ) + sprintf "* `make %s`: %s\n" target doc) |> String.concat ~sep:"" ; sprintf "SSH: the command `make ssh` *outputs* an SSH command \ @@ -372,8 +339,7 @@ module Run_environment = struct $ tar c some/dir/ | $(make ssh) 'tar x'\n\n\ (may need to be `tar -x -f -` for BSD tar).\n" (Option.value_map ~default:"No root-password" root_password - ~f:(sprintf "Root-password: %S")) ])) - in + ~f:(sprintf "Root-password: %S")) ])) in ("Makefile", ("all: help" :: makefile) @ help @ [""]) :: !other_files module Example = struct @@ -385,11 +351,9 @@ module Run_environment = struct [ ("opkg-update", exec ["opkg"; "update"]) ; ("install-od", exec ["opkg"; "install"; "coreutils-od"]) ; ("install-make", exec ["opkg"; "install"; "make"]) ]) - @ more_setup - in + @ more_setup in let base_url = - "https://downloads.openwrt.org/snapshots/trunk/realview/generic/" - in + "https://downloads.openwrt.org/snapshots/trunk/realview/generic/" in qemu_arm "qemu_arm_openwrt" ~ssh_port ~machine:"realview-pbx-a9" ~kernel:(http (base_url // "openwrt-realview-vmlinux.elf")) ~sd_card:(http (base_url // "openwrt-realview-sdcard.img")) @@ -401,15 +365,13 @@ module Run_environment = struct See {{:https://people.debian.org/~aurel32/qemu/armhf/}}. *) let aurel32 file = - http ("https://people.debian.org/~aurel32/qemu/armhf" // file) - in + http ("https://people.debian.org/~aurel32/qemu/armhf" // file) in let setup = let open Genspio.EDSL in Setup.ssh_to_vm (check_sequence [("apt-get-make", exec ["apt-get"; "install"; "--yes"; "make"])]) - @ more_setup - in + @ more_setup in qemu_arm "qemu_arm_wheezy" ~ssh_port ~machine:"vexpress-a9" ~kernel:(aurel32 "vmlinuz-3.2.0-4-vexpress") ~sd_card:(aurel32 "debian_wheezy_armhf_standard.qcow2") @@ -454,8 +416,7 @@ let cmdf fmt = (fun cmd -> match Sys.command cmd with | 0 -> () - | other -> ksprintf failwith "Command %S did not return 0: %d" cmd other - ) + | other -> ksprintf failwith "Command %S did not return 0: %d" cmd other) fmt let write_lines p l = @@ -468,9 +429,8 @@ let () = ksprintf (fun s -> eprintf "Wrong CLI: %s\n%!" s ; - exit 2 ) - fmt - in + exit 2) + fmt in let example = ref None in let path = ref None in let ssh_port = ref 20202 in @@ -487,21 +447,19 @@ let () = , "Qemu x86_64 with FreeBSD." ) ; ( "amd64-dw" , Run_environment.Example.qemu_amd64_darwin - , "Qemu x86_64 with Darwin 8 (old Mac OSX)." ) ] - in + , "Qemu x86_64 with Darwin 8 (old Mac OSX)." ) ] in let set_example arg = match !example with - | Some s -> fail "Too many arguments (%S)!" arg + | Some _ -> fail "Too many arguments (%S)!" arg | None -> example := Some ( match List.find_map examples ~f:(fun (e, v, _) -> - if e = arg then Some v else None ) + if e = arg then Some v else None) with | Some s -> s - | None -> fail "Don't know VM %S" arg ) - in + | None -> fail "Don't know VM %S" arg ) in let args = Arg.align [ ( "--ssh-port" @@ -513,50 +471,44 @@ let () = (String.concat ~sep:"\n" (List.map ~f:(fun (n, _, d) -> - sprintf "%s* `%s`: %s" (String.make 25 ' ') n d ) + sprintf "%s* `%s`: %s" (String.make 25 ' ') n d) examples)) ) ; ( "--copy" , Arg.String (fun s -> let add p lp = let local_rel = - String.map p ~f:(function '/' -> '_' | c -> c) - in + String.map p ~f:(function '/' -> '_' | c -> c) in copy_directories := (p, local_rel, lp) :: !copy_directories in match String.split ~on:(`Character ':') s with | [] | [_] -> fail "Error in --copy: need a `:` separator (%S)" s | [p; lp] -> add p lp - | p :: more -> add p (String.concat ~sep:":" more) ) + | p :: more -> add p (String.concat ~sep:":" more)) , " Copy in the output directory and add its \ upload to the VM to the `make setup` target as a relative path \ - ." ) ] - in + ." ) ] in let usage = sprintf "vm-tester --vm " in let anon arg = match !path with - | Some s -> fail "Too many arguments (%S)!" arg - | None -> path := Some arg - in + | Some _ -> fail "Too many arguments (%S)!" arg + | None -> path := Some arg in Arg.parse args anon usage ; let more_setup = List.map !copy_directories ~f:(fun (_, locrel, hostp) -> - Run_environment.Setup.copy (`Relative locrel) (`Relative hostp) ) - in + Run_environment.Setup.copy (`Relative locrel) (`Relative hostp)) in let re = match !example with | Some e -> e ~ssh_port:!ssh_port more_setup - | None -> fail "Missing VM name\nUsage: %s" usage - in + | None -> fail "Missing VM name\nUsage: %s" usage in let content = Run_environment.setup_dir_content re in let path = match !path with | Some p -> p - | None -> fail "Missing path!\nUsage: %s" usage - in + | None -> fail "Missing path!\nUsage: %s" usage in List.iter content ~f:(fun (filepath, content) -> let full = path // filepath in cmdf "mkdir -p %s" (Filename.dirname full) ; - write_lines full content ) ; + write_lines full content) ; List.iter !copy_directories ~f:(fun (p, local_rel, _) -> - cmdf "rsync -az %s %s/%s" p path local_rel ) + cmdf "rsync -az %s %s/%s" p path local_rel) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index 5fbaa9f..d4c893e 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -1,45 +1,34 @@ -type 'a t = 'a Language.t +open Common +type 'a t = 'a Language.t type c_string = Language.c_string - type byte_array = Language.byte_array - type fd_redirection = Language.fd_redirection -let ( // ) = Filename.concat +let ( // ) = Caml.Filename.concat open Language.Construct -open Nonstd -module String = Sosa.Native_string -include Base +include Language.Construct.Base module Magic = Magic type str = Language.byte_array let str = byte_array - let string = str module Str = struct include Byte_array let equals = ( =$= ) - let concat_elist e = byte_array_concat_list e - let concat_list l = concat_elist (Elist.make l) end let call l = call @@ List.map ~f:to_c_string l - let strs l = List.map ~f:str l - let exec l = call (strs l) - let getenv str = getenv (to_c_string str) |> to_byte_array - let setenv ~var v = setenv ~var:(to_c_string var) (to_c_string v) - let file_exists s = file_exists (to_c_string s) let write_output ?stdout ?stderr ?return_value u = @@ -49,20 +38,17 @@ let write_output ?stdout ?stderr ?return_value u = write_output ?stdout ?stderr ?return_value u let to_file take file = to_file take (to_c_string file) - let write_stdout ~path expr = write_output expr ~stdout:path module Elist = struct include Elist let serialize_str_list sl = serialize_byte_array_list sl - let deserialize_to_str_list sl = deserialize_to_byte_array_list sl end module Bool = struct let of_string s = Bool.of_string (to_c_string s) - let to_string b = Bool.to_string b |> to_byte_array end @@ -70,25 +56,22 @@ module Integer = struct include Integer let to_str = to_byte_array - let of_str = of_byte_array end let case condition body = `Case (condition, seq body) - let default d = `Default (seq d) let switch l = let default = ref None in let cases = List.filter_map l ~f:(function - | `Default d when !default <> None -> + | `Default _ when Poly.(!default <> None) -> failwith "Cannot build switch with >1 defaults" | `Default d -> default := Some d ; None - | `Case t -> Some t ) - in + | `Case t -> Some t) in make_switch ~default:(Option.value ~default:nop !default) cases (* @@ -116,23 +99,19 @@ let tmp_file ?tmp_dir name : file = if_then_else Str.(getenv (str "TMPDIR") <$> str "") (call [str "printf"; str "%s"; getenv (str "TMPDIR")]) - (exec ["printf"; "%s"; default_tmp_dir]))) - in + (exec ["printf"; "%s"; default_tmp_dir]))) in let path = let clean = String.map name ~f:(function | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') as c -> c - | other -> '_' ) - in + | _ -> '_') in Str.concat_list - [ get_tmp_dir - ; str "/" + [ get_tmp_dir; str "/" ; str - (sprintf "genspio-tmp-file-%s-%s" clean - Digest.(string name |> to_hex)) ] - in + (Fmt.str "genspio-tmp-file-%s-%s" clean + Caml.Digest.(string name |> to_hex)) ] in let tmp = Str.concat_list [path; string "-tmp"] in - object (self) + object (_self) method get = get_stdout (call [string "cat"; path]) method path = path @@ -161,7 +140,6 @@ let if_seq ~t ?e c = | Some f -> if_then_else c (seq t) (seq f) let printf fmt l = call (string "printf" :: string "--" :: fmt :: l) - let eprintf fmt l = with_redirections (printf fmt l) [to_fd (int 1) (int 2)] module Command_line = struct @@ -185,17 +163,16 @@ module Command_line = struct Opt_flag {switches; doc; default} let ( & ) x y = Opt_cons (x, y) - let usage s = Opt_end s end let parse (options : ('a, unit t) cli_options) (action : anon:str list t -> 'a) : unit t = let prefix = Common.Unique_name.variable "getopts" in - let variable {switches; doc} = - sprintf "%s_%s" prefix - (String.concat ~sep:"" switches |> Digest.string |> Digest.to_hex) - in + let variable {switches; _} = + Fmt.str "%s_%s" prefix + ( String.concat ~sep:"" switches + |> Caml.Digest.string |> Caml.Digest.to_hex ) in let inits = ref [] in let to_init s = inits := s :: !inits in let cases = ref [] in @@ -205,7 +182,7 @@ module Command_line = struct let to_help s = help := s :: !help in let string_of_var var = getenv (string var) in let bool_of_var var = getenv (string var) |> Bool.of_string in - let anon_var = ksprintf str "%s_anon" prefix in + let anon_var = Fmt.kstr str "%s_anon" prefix in let anon = anon_var |> getenv |> Elist.deserialize_to_str_list in let applied_action = (* @@ -233,11 +210,11 @@ module Command_line = struct f | Opt_cons (Opt_string x, more) -> let var = variable x in - to_init (setenv (string var) x.default) ; + to_init (setenv ~var:(string var) x.default) ; to_case (case (List.fold ~init:(bool false) x.switches ~f:(fun p s -> - p ||| Str.(str s =$= getenv (str "1")) )) + p ||| Str.(str s =$= getenv (str "1")))) [ if_seq Str.(getenv (string "2") =$= string "") ~t: @@ -245,50 +222,45 @@ module Command_line = struct (string "ERROR option '%s' requires an argument\\n") [getenv (string "1")] ; fail "Wrong command line" ] - ~e:[setenv (string var) (getenv (string "2"))] + ~e:[setenv ~var:(string var) (getenv (string "2"))] ; exec ["shift"] ; exec ["shift"] ]) ; - ksprintf to_help "* `%s `: %s" + Fmt.kstr to_help "* `%s `: %s" (String.concat ~sep:"," x.switches) x.doc ; loop (f (string_of_var var)) more | Opt_cons (Opt_flag x, more) -> let var = variable x in - to_init (setenv (string var) (Bool.to_string x.default)) ; + to_init (setenv ~var:(string var) (Bool.to_string x.default)) ; to_case (case (List.fold ~init:(bool false) x.switches ~f:(fun p s -> - p ||| Str.equals (string s) (getenv (string "1")) )) - [ setenv (string var) (Bool.to_string (bool true)) + p ||| Str.equals (string s) (getenv (string "1")))) + [ setenv ~var:(string var) (Bool.to_string (bool true)) ; exec ["shift"] ]) ; - ksprintf to_help "* `%s`: %s" + Fmt.kstr to_help "* `%s`: %s" (String.concat ~sep:"," x.switches) x.doc ; - loop (f (bool_of_var var)) more - in - loop (action ~anon) options - in + loop (f (bool_of_var var)) more in + loop (action ~anon) options in let help_msg = - sprintf "%s\n\nOptions:\n\n%s\n" !help_intro - (String.concat ~sep:"\n" (List.rev !help)) - in - let help_flag_var = ksprintf string "%s_help" prefix in + Fmt.str "%s\n\nOptions:\n\n%s\n" !help_intro + (String.concat ~sep:"\n" (List.rev !help)) in + let help_flag_var = Fmt.kstr string "%s_help" prefix in let while_loop = let body = let append_anon_arg_to_list = - setenv anon_var + setenv ~var:anon_var ( Elist.append anon (Elist.make [getenv (string "1")]) - |> Elist.serialize_str_list ) - in + |> Elist.serialize_str_list ) in let help_case = let help_switches = ["-h"; "-help"; "--help"] in case (List.fold ~init:(bool false) help_switches ~f:(fun p s -> - p ||| Str.(str s =$= getenv (str "1")) )) - [ setenv help_flag_var (Bool.to_string (bool true)) + p ||| Str.(str s =$= getenv (str "1")))) + [ setenv ~var:help_flag_var (Bool.to_string (bool true)) ; byte_array help_msg >> exec ["cat"] - ; exec ["break"] ] - in + ; exec ["break"] ] in let dash_dash_case = case Str.(getenv (str "1") =$= str "--") @@ -296,29 +268,24 @@ module Command_line = struct ; loop_while Str.(getenv (str "#") <$> str "0") ~body:(seq [append_anon_arg_to_list; exec ["shift"]]) - ; exec ["break"] ] - in + ; exec ["break"] ] in let anon_case = case Str.(getenv (str "#") <$> str "0") - [append_anon_arg_to_list; exec ["shift"]] - in + [append_anon_arg_to_list; exec ["shift"]] in let default_case = default [exec ["break"]] in let cases = (help_case :: List.rev !cases) - @ [dash_dash_case; anon_case; default_case] - in - seq [switch cases] - in - loop_while (bool true) ~body - in + @ [dash_dash_case; anon_case; default_case] in + seq [switch cases] in + loop_while (bool true) ~body in seq - [ setenv help_flag_var (Bool.to_string (bool false)) - ; setenv anon_var (Elist.serialize_byte_array_list (Elist.make [])) + [ setenv ~var:help_flag_var (Bool.to_string (bool false)) + ; setenv ~var:anon_var (Elist.serialize_byte_array_list (Elist.make [])) ; seq (List.rev !inits) ; while_loop ; if_then_else - (bool_of_var (sprintf "%s_help" prefix)) + (bool_of_var (Fmt.str "%s_help" prefix)) nop applied_action ] end @@ -331,8 +298,7 @@ let loop_until_true ?(attempts = 20) ?(sleep = 2) method set v = setenv ~var:varname (Integer.to_str v) method get = getenv varname |> Integer.of_str - end - in + end in seq [ intvar#set (int 1) ; loop_while @@ -343,12 +309,12 @@ let loop_until_true ?(attempts = 20) ?(sleep = 2) ; intvar#set Integer.(intvar#get + int 1) ; if_then Integer.(intvar#get <= int attempts) - (exec ["sleep"; sprintf "%d" sleep]) ]) + (exec ["sleep"; Fmt.str "%d" sleep]) ]) ; exec ["printf"; "\\n"] ; if_then_else Integer.(intvar#get > int attempts) - (seq [(* sprintf "Command failed %d times!" attempts; *) exec ["false"]]) - (seq [(* sprintf "Command failed %d times!" attempts; *) exec ["true"]]) + (seq [(* Fmt.str "Command failed %d times!" attempts; *) exec ["false"]]) + (seq [(* Fmt.str "Command failed %d times!" attempts; *) exec ["true"]]) ] |> returns ~value:0 @@ -357,14 +323,13 @@ let silently u = write_output ~stdout:dev_null ~stderr:dev_null u let succeeds_silently u = silently u |> succeeds - let seq_and l = List.fold l ~init:(bool true) ~f:(fun u v -> u &&& succeeds v) let output_markdown_code tag f = seq - [ exec ["printf"; sprintf "``````````%s\\n" tag] + [ exec ["printf"; Fmt.str "``````````%s\\n" tag] ; f - ; exec ["printf"; sprintf "\\n``````````\\n"] ] + ; exec ["printf"; Fmt.str "\\n``````````\\n"] ] let cat_markdown tag file = output_markdown_code tag @@ call [string "cat"; file] @@ -373,32 +338,31 @@ let fresh_name suf = let x = object method v = 42 - end - in - sprintf "g-%d-%d-%s" (Oo.id x) (Random.int 100_000) suf + end in + Fmt.str "g-%d-%d-%s" (Caml.Oo.id x) (Random.int 100_000) suf let sanitize_name n = String.map n ~f:(function | ('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-') as c -> c - | other -> '_' ) + | _ -> '_') -let default_on_failure ~step:(i, u) ~stdout ~stderr = +let default_on_failure ~step:(i, _) ~stdout ~stderr = seq - [ printf (ksprintf str "Step '%s' FAILED:\\n" i) [] + [ printf (Fmt.kstr str "Step '%s' FAILED:\\n" i) [] ; cat_markdown "stdout" stdout ; cat_markdown "stderr" stderr ; exec ["false"] ] let check_sequence ?(verbosity = `Announce ">> ") ?(on_failure = default_on_failure) - ?(on_success = fun ~step ~stdout ~stderr -> nop) ?(tmpdir = "/tmp") cmds = + ?(on_success = fun ~step:_ ~stdout:_ ~stderr:_ -> nop) ?(tmpdir = "/tmp") + cmds = let tmp_prefix = fresh_name "-cmd" in let tmpout which id = str ( tmpdir - // sprintf "genspio-check-sequence-%s-%s-%s" tmp_prefix which - (sanitize_name id) ) - in + // Fmt.str "genspio-check-sequence-%s-%s-%s" tmp_prefix which + (sanitize_name id) ) in let stdout id = tmpout "stdout" id in let stderr id = tmpout "stderr" id in let log id u = @@ -406,12 +370,11 @@ let check_sequence ?(verbosity = `Announce ">> ") | `Silent -> write_output ~stdout:(stdout id) ~stderr:(stderr id) u | `Announce prompt -> seq - [ printf (ksprintf str "%s %s\\n" prompt id) [] + [ printf (Fmt.kstr str "%s %s\\n" prompt id) [] ; write_output ~stdout:(stdout id) ~stderr:(stderr id) u ] - | `Output_all -> u - in + | `Output_all -> u in let check idx (nam, u) next = - let id = sprintf "%d. %s" idx nam in + let id = Fmt.str "%d. %s" idx nam in if_seq (log id u |> succeeds) ~t: @@ -420,8 +383,7 @@ let check_sequence ?(verbosity = `Announce ">> ") in let rec loop i = function | one :: more -> check i one (loop (i + 1) more) - | [] -> exec ["true"] - in + | [] -> exec ["true"] in loop 1 cmds let on_stdin_lines body = @@ -441,7 +403,7 @@ let get_stdout_one_line ?(first_line = false) ?(remove_spaces = false) u = let verbose_call ?(prefix = "CALL: ") ?(verbose = bool true) l = if_seq verbose ~t: - [ eprintf (ksprintf str "%s[" prefix) [] + [ eprintf (Fmt.kstr str "%s[" prefix) [] ; seq @@ List.map l ~f:(fun ex -> eprintf (string "%s ") [ex]) ; eprintf (string "]\\n") [] ; call l ] @@ -449,7 +411,7 @@ let verbose_call ?(prefix = "CALL: ") ?(verbose = bool true) l = let check_sequence_with_output l = check_sequence ~verbosity:`Output_all - (List.mapi l ~f:(fun i c -> (sprintf "Step-%d" i, c))) + (List.mapi l ~f:(fun i c -> (Fmt.str "Step-%d" i, c))) let is_regular_file path = call [string "test"; string "-f"; path] |> succeeds_silently @@ -458,33 +420,26 @@ let is_directory path = call [string "test"; string "-d"; path] |> succeeds_silently let is_executable path = succeeds_silently @@ call [str "test"; str "-x"; path] - let is_readable path = succeeds_silently @@ call [str "test"; str "-r"; path] - let mkdir_p path = call [str "mkdir"; str "-p"; path] - -let exit n = exec ["exit"; string_of_int n] - +let exit n = exec ["exit"; Int.to_string n] let home_path () = getenv (str "HOME") - let ( ^$^ ) a b = Str.concat_list [a; b] - let ( /// ) a b = Str.concat_list [a; str "/"; b] - -let say fmt l = eprintf (ksprintf string "%s\\n" fmt) l +let say fmt l = eprintf (Fmt.kstr string "%s\\n" fmt) l let ensure what ~condition ~how = if_seq condition - ~t:[ksprintf say "%s -> already done" what []] + ~t:[Fmt.kstr say "%s -> already done" what []] ~e: [ check_sequence - ~verbosity:(`Announce (sprintf "-> %s: in-progress" what)) + ~verbosity:(`Announce (Fmt.str "-> %s: in-progress" what)) ~on_failure:(fun ~step ~stdout ~stderr -> seq [ say "FAILURE: %s" [str (fst step)] ; cat_markdown "stdout" stdout ; cat_markdown "stderr" stderr - ; fail "FATAL ERROR" ] ) + ; fail "FATAL ERROR" ]) how ; if_then_else condition nop (seq @@ -493,16 +448,14 @@ let ensure what ~condition ~how = let greps_to ?(extended_re = false) re u = let c = - [string "grep"] @ (if extended_re then [string "-E"] else []) @ [re] - in + [string "grep"] @ (if extended_re then [string "-E"] else []) @ [re] in succeeds_silently (u ||> call c) let pager ?(file_descriptor = str "1") ?disable ?(default_command = exec ["more"]) () = let with_disable = Option.value_map disable ~default:[] ~f:(fun cond -> - [case cond [exec ["cat"]]] ) - in + [case cond [exec ["cat"]]]) in switch ( with_disable @ [ case @@ -515,7 +468,6 @@ let pager ?(file_descriptor = str "1") ?disable module Script_with_describe (P : sig val name : string - val description : string end) = struct @@ -524,12 +476,12 @@ struct let describe_option_and_usage ?(more_usage = []) () = let open Command_line.Arg in flag ["--describe"] ~doc:P.description - & ksprintf usage "usage: %s \n%s.%s" P.name P.description - (List.map more_usage ~f:(sprintf "\n%s") |> String.concat ~sep:"") + & Fmt.kstr usage "usage: %s \n%s.%s" P.name P.description + (List.map more_usage ~f:(Fmt.str "\n%s") |> String.concat ~sep:"") let deal_with_describe describe more = if_seq describe - ~t:[printf (ksprintf string "%s\\n" P.description) []] + ~t:[printf (Fmt.kstr string "%s\\n" P.description) []] ~e:more end @@ -542,35 +494,32 @@ module Dispatcher_script = struct List.fold ~init:(eq s1 (string h)) t - ~f:(fun p v -> p ||| eq s1 (string v)) - in + ~f:(fun p v -> p ||| eq s1 (string v)) in let pr_usage = seq [ printf - (ksprintf string + (Fmt.kstr string "usage: %s [OPTIONS/ARGS]\\n\\n%s.\\n\\nSub-commands:\\n" name description) [] ; (let findgrep = - ksprintf Magic.unit + Fmt.kstr Magic.unit "{ ls -1 $(echo $PATH | tr ':' ' ') | grep -E '%s-[^-]*$' | \ sort -u ; } 2> /dev/null" - name - in + name in findgrep ||> on_stdin_lines (fun line -> printf (string "* %s: %s\\n") [ line ; get_stdout ( call [line; string "--describe"] - ||> exec ["tr"; "-d"; "\\n"] ) ] )) + ||> exec ["tr"; "-d"; "\\n"] ) ])) ; printf (str "Aliases:\\n") [] ; seq (List.map aliases ~f:(fun (a, v) -> - printf (str "* %s -> %s\\n") [a; v] )) ] - in + printf (str "* %s -> %s\\n") [a; v])) ] in let dollar_one_empty = Str.(getenv (string "1") =$= string "") in - let tmp = ksprintf tmp_file "%s-call" name in + let tmp = Fmt.kstr tmp_file "%s-call" name in seq [ if_seq ( dollar_one_empty @@ -581,7 +530,7 @@ module Dispatcher_script = struct ~e: [ if_seq Str.(getenv (string "1") =$= string "--describe") - ~t:[printf (ksprintf string "%s\\n" description) []] + ~t:[printf (Fmt.kstr string "%s\\n" description) []] ~e: [ write_stdout ~path:tmp#path (seq @@ -590,7 +539,7 @@ module Dispatcher_script = struct ( List.map aliases ~f:(fun (a, v) -> case Str.(a =$= getenv (string "1")) - [printf (str "%s") [v]] ) + [printf (str "%s") [v]]) @ [default [printf (str "%s") [getenv (str "1")]]] ) ; exec ["shift"] diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 9a6f21a..e2477c0 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -1,8 +1,9 @@ (** The Embedded Domain Specific Lanaguage to create “shell-expressions.” *) -(** The type of a Genspio expression. *) type 'a t = 'a Language.t +(** The type of a Genspio expression. *) +type str = Language.byte_array (** Type to encode arbitrary byte-arrays in the EDSL as [str t] values, OCaml literal strings or the outputs (as in [stdout]) of processes are byte-arrays. @@ -13,18 +14,19 @@ type 'a t = 'a Language.t environment variables must be C-strings. Genspio treats them properly by failing when a wrong byte-array needs to be converted to a C-string. *) -type str = Language.byte_array + +type byte_array = Language.byte_array +type c_string = Language.c_string (** {3 Literals } *) val str : string -> str t -(** Create a {!type:c_string} literal. *) +(** Create a {!type:byte_array} literal. *) val string : string -> str t (** [string] is an alias for {!function:str}. *) val int : int -> int t - val bool : bool -> bool t (** {3 Comments} *) @@ -60,7 +62,7 @@ val setenv : var:str t -> str t -> unit t If the [~var] argument is not a valid variable name or if the value does not fit in a shell variable (e.g. newlines), behavior is undefined. - + Also, the total environment of a UNIX process counts towards the total size of the arguments passed on to a sub-process (see usually the result of ["getconf ARG_MAX"]). Genspio does not check @@ -73,9 +75,7 @@ val setenv : var:str t -> str t -> unit t (** {3 Boolean Expressions} *) val ( &&& ) : bool t -> bool t -> bool t - val ( ||| ) : bool t -> bool t -> bool t - val not : bool t -> bool t val returns : 'a t -> value:int -> bool t @@ -91,7 +91,6 @@ val file_exists : str t -> bool t (** Conversions of the [bool t] type. *) module Bool : sig val to_string : bool t -> str t - val of_string : str t -> bool t end @@ -100,56 +99,33 @@ end (** Functions on [int t] values (arithmetic, comparisons, conversions, etc.). *) module Integer : sig val to_str : int t -> str t - val of_str : str t -> int t val bin_op : int t -> [`Div | `Minus | `Mult | `Plus | `Mod] -> int t -> int t val add : int t -> int t -> int t - val ( + ) : int t -> int t -> int t - val sub : int t -> int t -> int t - val ( - ) : int t -> int t -> int t - val mul : int t -> int t -> int t - val ( * ) : int t -> int t -> int t - val div : int t -> int t -> int t - val ( / ) : int t -> int t -> int t - val modulo : int t -> int t -> int t - val ( mod ) : int t -> int t -> int t - val cmp : [`Eq | `Ge | `Gt | `Le | `Lt | `Ne] -> int t -> int t -> bool t - val eq : int t -> int t -> bool t - val ne : int t -> int t -> bool t - val lt : int t -> int t -> bool t - val le : int t -> int t -> bool t - val ge : int t -> int t -> bool t - val gt : int t -> int t -> bool t - val ( = ) : int t -> int t -> bool t - val ( <> ) : int t -> int t -> bool t - val ( < ) : int t -> int t -> bool t - val ( <= ) : int t -> int t -> bool t - val ( >= ) : int t -> int t -> bool t - val ( > ) : int t -> int t -> bool t end @@ -168,15 +144,10 @@ module Elist : sig function that returns the current eletment at the EDSL level. *) val serialize_byte_array_list : str list t -> str t - val deserialize_to_byte_array_list : str t -> str list t - val serialize_str_list : str list t -> str t - val deserialize_to_str_list : str t -> str list t - val serialize_int_list : int list t -> str t - val deserialize_to_int_list : str t -> int list t end @@ -184,9 +155,7 @@ end module Str : sig val equals : str t -> str t -> bool t - val ( =$= ) : str t -> str t -> bool t - val ( <$> ) : str t -> str t -> bool t val concat_list : str t list -> str t @@ -202,7 +171,6 @@ val nop : unit t (** The silent “no-operation.” *) val if_then_else : bool t -> unit t -> unit t -> unit t - val if_then : bool t -> unit t -> unit t val seq : unit t list -> unit t @@ -244,8 +212,8 @@ val make_switch : (** {3 Redirections and File Descriptors } *) -(** Abstract type of file-descriptor redirections. *) type fd_redirection +(** Abstract type of file-descriptor redirections. *) val to_fd : int t -> int t -> fd_redirection (** Create a file-descriptor to file-descriptor redirection. *) @@ -254,7 +222,7 @@ val to_file : int t -> str t -> fd_redirection (** Create a file-descriptor to file redirection. *) val with_redirections : unit t -> fd_redirection list -> unit t -(** +(** Run a [unit t] expression after applying a list of file-descriptor redirections. @@ -312,18 +280,18 @@ val fail : string -> unit t (** {3 Temporary Files} *) -(** Abstraction of a file, cf. {!tmp_file}. *) type file = < get: str t (** Get the current contents of the file *) ; set: str t -> unit t ; append: str t -> unit t ; delete: unit t ; path: str t > +(** Abstraction of a file, cf. {!tmp_file}. *) val tmp_file : ?tmp_dir:str t -> string -> file (** Create a temporary file that may contain arbitrary strings (can be used as variable containing [string t] values). - + [tmp_file "foo"] points to a path that is a {b function} of the string ["foo"]; it does not try to make temporary-files unique, on the contrary: two calls to [tmp_file "foo"] ensure that @@ -334,7 +302,7 @@ val tmp_file : ?tmp_dir:str t -> string -> file (** Typed command-line parsing for your shell scripts, à la {!Printf.scanf}. *) module Command_line : sig - (** + (** Use this module like OCaml's {!Printf.scanf} function. @@ -369,7 +337,7 @@ module Command_line : sig string Genspio.EDSL.t -> string Genspio.EDSL.t -> unit Genspio.EDSL.t, unit Genspio.EDSL.t) Genspio.EDSL.Command_line.cli_options - + so the action function (the second argument to parse) must have type: anon:string list Genspio.EDSL.t -> @@ -565,7 +533,7 @@ val ensure : string -> condition:bool t -> how:(string * unit t) list -> unit t - If [true] do nothing, succeed - If [false], run [~how] with {!check_sequence}. - Test the condition again, if [true] succeed, if [false] fail. - + Failures happen thanks to the !{fail} call. *) @@ -615,11 +583,9 @@ Composer Example} which is where the above snippet comes from. *) module Script_with_describe (P : sig val name : string - val description : string end) : sig val name : string - val description : string val describe_option_and_usage : @@ -641,18 +607,18 @@ module Dispatcher_script : sig -> description:string -> unit -> unit Genspio__Language.t - (** + (** Make a “toplevel” script that behaves a bit like ["git"] by calling [name ^ "-${1}"]. The search for the argument can be “hijacked” with the list of [~aliases]; with [~name:"hello"] and [~aliases:[str "W", str "wolrd"]], when ["hello W"] is called, the generated script with lool for ["hello-world"] in the ["$PATH"]. - + Just like scripts made with {!Script_with_describe}, the [~description] argument is used to answer the ["--describe"] command line option. - + When called without arguments, with ["-h"], ["-help"], or with ["--help"], the script lists all the commands it can find and the aliases. E.g.: diff --git a/src/lib/EDSL_v0.ml b/src/lib/EDSL_v0.ml index ba922a0..d477daf 100644 --- a/src/lib/EDSL_v0.ml +++ b/src/lib/EDSL_v0.ml @@ -1,32 +1,27 @@ -type 'a t = 'a Language.t +open Common +type 'a t = 'a Language.t type c_string = Language.c_string - type byte_array = Language.byte_array - type fd_redirection = Language.fd_redirection -let ( // ) = Filename.concat +let ( // ) = Caml.Filename.concat include Language.Construct -open Nonstd -module String = Sosa.Native_string let case condition body = `Case (condition, seq body) - let default d = `Default (seq d) let switch l = let default = ref None in let cases = List.filter_map l ~f:(function - | `Default d when !default <> None -> + | `Default _ when Poly.(!default <> None) -> failwith "Cannot build switch with >1 defaults" | `Default d -> default := Some d ; None - | `Case t -> Some t ) - in + | `Case t -> Some t) in make_switch ~default:(Option.value ~default:nop !default) cases (* @@ -58,21 +53,17 @@ let tmp_file ?tmp_dir name : file = (call [c_string "printf"; c_string "%s"; getenv (c_string "TMPDIR")]) (exec ["printf"; "%s"; default_tmp_dir])) - |> to_c_string ) - in + |> to_c_string ) in let path = let clean = String.map name ~f:(function | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') as c -> c - | other -> '_' ) - in + | _ -> '_') in C_string.concat_list - [ get_tmp_dir - ; c_string "/" + [ get_tmp_dir; c_string "/" ; c_string - (sprintf "genspio-tmp-file-%s-%s" clean - Digest.(string name |> to_hex)) ] - in + (Fmt.str "genspio-tmp-file-%s-%s" clean + Caml.Digest.(string name |> to_hex)) ] in let tmp = C_string.concat_list [path; string "-tmp"] in object (self) method get = get_stdout (call [string "cat"; path]) @@ -106,7 +97,6 @@ let if_seq ~t ?e c = | Some f -> if_then_else c (seq t) (seq f) let printf fmt l = call (string "printf" :: string "--" :: fmt :: l) - let eprintf fmt l = with_redirections (printf fmt l) [to_fd (int 1) (int 2)] module Command_line = struct @@ -130,17 +120,16 @@ module Command_line = struct Opt_flag {switches; doc; default} let ( & ) x y = Opt_cons (x, y) - let usage s = Opt_end s end let parse (options : ('a, unit t) cli_options) (action : anon:c_string list t -> 'a) : unit t = let prefix = Common.Unique_name.variable "getopts" in - let variable {switches; doc} = - sprintf "%s_%s" prefix - (String.concat ~sep:"" switches |> Digest.string |> Digest.to_hex) - in + let variable {switches; _} = + Fmt.str "%s_%s" prefix + ( String.concat ~sep:"" switches + |> Caml.Digest.string |> Caml.Digest.to_hex ) in let inits = ref [] in let to_init s = inits := s :: !inits in let cases = ref [] in @@ -151,8 +140,8 @@ module Command_line = struct let string_of_var var = getenv (string var) in let bool_of_var var = getenv (string var) |> Bool.of_string in let anon_tmp = - ksprintf tmp_file "parse-cli-%s" - (Marshal.to_string options [] |> Digest.string |> Digest.to_hex) + Fmt.kstr tmp_file "parse-cli-%s" + Caml.(Marshal.to_string options [] |> Digest.string |> Digest.to_hex) in let anon = anon_tmp#get |> Elist.deserialize_to_c_string_list in let applied_action = @@ -181,11 +170,11 @@ module Command_line = struct f | Opt_cons (Opt_string x, more) -> let var = variable x in - to_init (setenv (string var) x.default) ; + to_init (setenv ~var:(string var) x.default) ; to_case (case (List.fold ~init:(bool false) x.switches ~f:(fun p s -> - p ||| C_string.(c_string s =$= getenv (c_string "1")) )) + p ||| C_string.(c_string s =$= getenv (c_string "1")))) [ if_seq C_string.(getenv (string "2") =$= string "") ~t: @@ -193,34 +182,31 @@ module Command_line = struct (string "ERROR option '%s' requires an argument\\n") [getenv (string "1")] ; fail "Wrong command line" ] - ~e:[setenv (string var) (getenv (string "2"))] + ~e:[setenv ~var:(string var) (getenv (string "2"))] ; exec ["shift"] ; exec ["shift"] ]) ; - ksprintf to_help "* `%s `: %s" + Fmt.kstr to_help "* `%s `: %s" (String.concat ~sep:"," x.switches) x.doc ; loop (f (string_of_var var)) more | Opt_cons (Opt_flag x, more) -> let var = variable x in - to_init (setenv (string var) (Bool.to_string x.default)) ; + to_init (setenv ~var:(string var) (Bool.to_string x.default)) ; to_case (case (List.fold ~init:(bool false) x.switches ~f:(fun p s -> - p ||| C_string.equals (string s) (getenv (string "1")) )) - [ setenv (string var) (Bool.to_string (bool true)) + p ||| C_string.equals (string s) (getenv (string "1")))) + [ setenv ~var:(string var) (Bool.to_string (bool true)) ; exec ["shift"] ]) ; - ksprintf to_help "* `%s`: %s" + Fmt.kstr to_help "* `%s`: %s" (String.concat ~sep:"," x.switches) x.doc ; - loop (f (bool_of_var var)) more - in - loop (action ~anon) options - in + loop (f (bool_of_var var)) more in + loop (action ~anon) options in let help_msg = - sprintf "%s\n\nOptions:\n\n%s\n" !help_intro - (String.concat ~sep:"\n" (List.rev !help)) - in - let help_flag_var = ksprintf string "%s_help" prefix in + Fmt.str "%s\n\nOptions:\n\n%s\n" !help_intro + (String.concat ~sep:"\n" (List.rev !help)) in + let help_flag_var = Fmt.kstr string "%s_help" prefix in let while_loop = let body = let append_anon_arg_to_list = @@ -229,17 +215,15 @@ module Command_line = struct ( Elist.append (anon_tmp#get |> Elist.deserialize_to_byte_array_list) (Elist.make [getenv (string "1") |> C_string.to_byte_array]) - |> Elist.serialize_byte_array_list ) ] - in + |> Elist.serialize_byte_array_list ) ] in let help_case = let help_switches = ["-h"; "-help"; "--help"] in case (List.fold ~init:(bool false) help_switches ~f:(fun p s -> - p ||| C_string.(c_string s =$= getenv (c_string "1")) )) - [ setenv help_flag_var (Bool.to_string (bool true)) + p ||| C_string.(c_string s =$= getenv (c_string "1")))) + [ setenv ~var:help_flag_var (Bool.to_string (bool true)) ; byte_array help_msg >> exec ["cat"] - ; exec ["break"] ] - in + ; exec ["break"] ] in let dash_dash_case = case C_string.(getenv (c_string "1") =$= c_string "--") @@ -247,29 +231,24 @@ module Command_line = struct ; loop_while C_string.(getenv (c_string "#") <$> c_string "0") ~body:(seq [append_anon_arg_to_list; exec ["shift"]]) - ; exec ["break"] ] - in + ; exec ["break"] ] in let anon_case = case C_string.(getenv (c_string "#") <$> c_string "0") - [append_anon_arg_to_list; exec ["shift"]] - in + [append_anon_arg_to_list; exec ["shift"]] in let default_case = default [exec ["break"]] in let cases = (help_case :: List.rev !cases) - @ [dash_dash_case; anon_case; default_case] - in - seq [switch cases] - in - loop_while (bool true) ~body - in + @ [dash_dash_case; anon_case; default_case] in + seq [switch cases] in + loop_while (bool true) ~body in seq - [ setenv help_flag_var (Bool.to_string (bool false)) + [ setenv ~var:help_flag_var (Bool.to_string (bool false)) ; anon_tmp#set (Elist.serialize_byte_array_list (Elist.make [])) ; seq (List.rev !inits) ; while_loop ; if_then_else - (bool_of_var (sprintf "%s_help" prefix)) + (bool_of_var (Fmt.str "%s_help" prefix)) nop applied_action ] end @@ -282,8 +261,7 @@ let loop_until_true ?(attempts = 20) ?(sleep = 2) method set v = setenv ~var:varname (Integer.to_string v) method get = getenv varname |> Integer.of_string - end - in + end in seq [ intvar#set (int 1) ; loop_while @@ -294,12 +272,12 @@ let loop_until_true ?(attempts = 20) ?(sleep = 2) ; intvar#set Integer.(intvar#get + int 1) ; if_then Integer.(intvar#get <= int attempts) - (exec ["sleep"; sprintf "%d" sleep]) ]) + (exec ["sleep"; Fmt.str "%d" sleep]) ]) ; exec ["printf"; "\\n"] ; if_then_else Integer.(intvar#get > int attempts) - (seq [(* sprintf "Command failed %d times!" attempts; *) exec ["false"]]) - (seq [(* sprintf "Command failed %d times!" attempts; *) exec ["true"]]) + (seq [(* Fmt.str "Command failed %d times!" attempts; *) exec ["false"]]) + (seq [(* Fmt.str "Command failed %d times!" attempts; *) exec ["true"]]) ] |> returns ~value:0 @@ -308,14 +286,13 @@ let silently u = write_output ~stdout:dev_null ~stderr:dev_null u let succeeds_silently u = silently u |> succeeds - let seq_and l = List.fold l ~init:(bool true) ~f:(fun u v -> u &&& succeeds v) let output_markdown_code tag f = seq - [ exec ["printf"; sprintf "``````````%s\\n" tag] + [ exec ["printf"; Fmt.str "``````````%s\\n" tag] ; f - ; exec ["printf"; sprintf "\\n``````````\\n"] ] + ; exec ["printf"; Fmt.str "\\n``````````\\n"] ] let cat_markdown tag file = output_markdown_code tag @@ call [string "cat"; file] @@ -324,32 +301,31 @@ let fresh_name suf = let x = object method v = 42 - end - in - sprintf "g-%d-%d-%s" (Oo.id x) (Random.int 100_000) suf + end in + Fmt.str "g-%d-%d-%s" (Caml.Oo.id x) (Random.int 100_000) suf let sanitize_name n = String.map n ~f:(function | ('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-') as c -> c - | other -> '_' ) + | _ -> '_') -let default_on_failure ~step:(i, u) ~stdout ~stderr = +let default_on_failure ~step:(i, _) ~stdout ~stderr = seq - [ printf (ksprintf c_string "Step '%s' FAILED:\\n" i) [] + [ printf (Fmt.kstr c_string "Step '%s' FAILED:\\n" i) [] ; cat_markdown "stdout" stdout ; cat_markdown "stderr" stderr ; exec ["false"] ] let check_sequence ?(verbosity = `Announce ">> ") ?(on_failure = default_on_failure) - ?(on_success = fun ~step ~stdout ~stderr -> nop) ?(tmpdir = "/tmp") cmds = + ?(on_success = fun ~step:_ ~stdout:_ ~stderr:_ -> nop) ?(tmpdir = "/tmp") + cmds = let tmp_prefix = fresh_name "-cmd" in let tmpout which id = c_string ( tmpdir - // sprintf "genspio-check-sequence-%s-%s-%s" tmp_prefix which - (sanitize_name id) ) - in + // Fmt.str "genspio-check-sequence-%s-%s-%s" tmp_prefix which + (sanitize_name id) ) in let stdout id = tmpout "stdout" id in let stderr id = tmpout "stderr" id in let log id u = @@ -357,12 +333,11 @@ let check_sequence ?(verbosity = `Announce ">> ") | `Silent -> write_output ~stdout:(stdout id) ~stderr:(stderr id) u | `Announce prompt -> seq - [ printf (ksprintf c_string "%s %s\\n" prompt id) [] + [ printf (Fmt.kstr c_string "%s %s\\n" prompt id) [] ; write_output ~stdout:(stdout id) ~stderr:(stderr id) u ] - | `Output_all -> u - in + | `Output_all -> u in let check idx (nam, u) next = - let id = sprintf "%d. %s" idx nam in + let id = Fmt.str "%d. %s" idx nam in if_seq (log id u |> succeeds) ~t: @@ -371,8 +346,7 @@ let check_sequence ?(verbosity = `Announce ">> ") in let rec loop i = function | one :: more -> check i one (loop (i + 1) more) - | [] -> exec ["true"] - in + | [] -> exec ["true"] in loop 1 cmds let on_stdin_lines body = diff --git a/src/lib/EDSL_v0.mli b/src/lib/EDSL_v0.mli index 451eaf7..667c58d 100644 --- a/src/lib/EDSL_v0.mli +++ b/src/lib/EDSL_v0.mli @@ -7,19 +7,19 @@ while the functions in the {!EDSL} module {i “hide”} the conversions *) -(** The type of a Genspio expression. *) type 'a t = 'a Language.t +(** The type of a Genspio expression. *) +type byte_array = Language.byte_array (** Type to encode arbitrary byte-arrays in the EDSL as [byte_array t] values, OCaml literal strings or the outputs (as in [stdout]) of processes are byte-arrays. *) -type byte_array = Language.byte_array +type c_string = Language.c_string (** Type to encode NUL-terminated strings in the EDSL as [c_string t] values. C-strings cannot contain the ['\x00'] character. The command line arguments of commands as well as the contents of environment variables must be C-strings. *) -type c_string = Language.c_string (** {3 Literals } *) @@ -33,7 +33,6 @@ val byte_array : string -> byte_array t (** Create a {!type:byte_array} literal. *) val int : int -> int t - val bool : bool -> bool t (** {3 Comments} *) @@ -82,9 +81,7 @@ val setenv : var:c_string t -> c_string t -> unit t (** {3 Boolean Expressions} *) val ( &&& ) : bool t -> bool t -> bool t - val ( ||| ) : bool t -> bool t -> bool t - val not : bool t -> bool t val returns : 'a t -> value:int -> bool t @@ -100,7 +97,6 @@ val file_exists : c_string t -> bool t (** Conversions of the [bool t] type. *) module Bool : sig val to_string : bool t -> c_string t - val of_string : c_string t -> bool t end @@ -109,60 +105,35 @@ end (** Functions on [int t] values (arithmetic, comparisons, conversions, etc.). *) module Integer : sig val to_string : int t -> c_string t - val to_byte_array : int t -> byte_array t - val of_string : c_string t -> int t - val of_byte_array : byte_array t -> int t val bin_op : int t -> [`Div | `Minus | `Mult | `Plus | `Mod] -> int t -> int t val add : int t -> int t -> int t - val ( + ) : int t -> int t -> int t - val sub : int t -> int t -> int t - val ( - ) : int t -> int t -> int t - val mul : int t -> int t -> int t - val ( * ) : int t -> int t -> int t - val div : int t -> int t -> int t - val ( / ) : int t -> int t -> int t - val modulo : int t -> int t -> int t - val ( mod ) : int t -> int t -> int t - val cmp : [`Eq | `Ge | `Gt | `Le | `Lt | `Ne] -> int t -> int t -> bool t - val eq : int t -> int t -> bool t - val ne : int t -> int t -> bool t - val lt : int t -> int t -> bool t - val le : int t -> int t -> bool t - val ge : int t -> int t -> bool t - val gt : int t -> int t -> bool t - val ( = ) : int t -> int t -> bool t - val ( <> ) : int t -> int t -> bool t - val ( < ) : int t -> int t -> bool t - val ( <= ) : int t -> int t -> bool t - val ( >= ) : int t -> int t -> bool t - val ( > ) : int t -> int t -> bool t end @@ -181,15 +152,10 @@ module Elist : sig function that returns the current eletment at the EDSL level. *) val serialize_byte_array_list : byte_array list t -> byte_array t - val deserialize_to_byte_array_list : byte_array t -> byte_array list t - val serialize_c_string_list : c_string list t -> byte_array t - val deserialize_to_c_string_list : byte_array t -> c_string list t - val serialize_int_list : int list t -> byte_array t - val deserialize_to_int_list : byte_array t -> int list t end @@ -197,23 +163,16 @@ end module Byte_array : sig val ( =$= ) : byte_array t -> byte_array t -> bool t - val ( <$> ) : byte_array t -> byte_array t -> bool t - val to_c_string : byte_array t -> c_string t - val to_c : byte_array t -> c_string t end module C_string : sig val equals : c_string t -> c_string t -> bool t - val ( =$= ) : c_string t -> c_string t -> bool t - val ( <$> ) : c_string t -> c_string t -> bool t - val to_byte_array : c_string t -> byte_array t - val to_bytes : c_string t -> byte_array t val concat_list : c_string t list -> c_string t @@ -229,7 +188,6 @@ val nop : unit t (** The silent “no-operation.” *) val if_then_else : bool t -> unit t -> unit t -> unit t - val if_then : bool t -> unit t -> unit t val seq : unit t list -> unit t @@ -271,8 +229,8 @@ val make_switch : (** {3 Redirections and File Descriptors } *) -(** Abstract type of file-descriptor redirections. *) type fd_redirection +(** Abstract type of file-descriptor redirections. *) val to_fd : int t -> int t -> fd_redirection (** Create a file-descriptor to file-descriptor redirection. *) @@ -343,7 +301,6 @@ val fail : string -> unit t (** {3 Temporary Files} *) -(** Abstraction of a file, cf. {!tmp_file}. *) type file = < get: byte_array t (** Get the current contents of the file *) ; get_c: c_string t @@ -352,6 +309,7 @@ type file = ; append: byte_array t -> unit t ; delete: unit t ; path: c_string t > +(** Abstraction of a file, cf. {!tmp_file}. *) val tmp_file : ?tmp_dir:c_string t -> string -> file (** Create a temporary file that may contain arbitrary strings (can be diff --git a/src/lib/common.ml b/src/lib/common.ml index 8420df6..fe9cfee 100644 --- a/src/lib/common.ml +++ b/src/lib/common.ml @@ -1,12 +1,11 @@ -include Nonstd -module String = Sosa.Native_string +include Base module Unique_name = struct let x = ref 0 let create prefix = - incr x ; - sprintf "%s_%d_%d" prefix !x (Random.int 100_000) + Caml.incr x ; + Fmt.str "%s_%d_%d" prefix !x (Random.int 100_000) let variable = create end diff --git a/src/lib/compile.ml b/src/lib/compile.ml index 3024541..ca838cb 100644 --- a/src/lib/compile.ml +++ b/src/lib/compile.ml @@ -1,7 +1,5 @@ open Common -type 'a t = 'a Language.t - let default_max_argument_length = Some 100_000 module To_posix = struct @@ -26,8 +24,7 @@ module To_posix = struct ; comment_backtrace: string list } let pp_error = Standard_compiler.pp_error - - let error_to_string = Format.asprintf "%a" pp_error + let error_to_string = Fmt.str "%a" pp_error type parameters = { style: [`One_liner | `Multi_line] @@ -38,27 +35,27 @@ module To_posix = struct let failure_to_stderr : death_function = fun ~comment_stack msg -> let summary s = - match String.sub s 0 65 with Some s -> s ^ " …" | None -> s - in - let open Format in - let big_string fmt s = Format.fprintf fmt "@[%s@]" (summary s) in + match String.sub s ~pos:0 ~len:65 with + | s -> s ^ " …" + | exception _ -> s in + let open Fmt in + let big_string ppf s = pf ppf "@[%s@]" (summary s) in let msg_str = - Format.asprintf "@[Error:@ @[%a@]%a@]" + str "@[Error:@ @[%a@]%a@]" (Standard_compiler.pp_death_message ~style:`User ~big_string) msg - (fun fmt () -> + (fun ppf () -> match comment_stack with - | [] -> fprintf fmt "" + | [] -> pf ppf "" | more -> - fprintf fmt ";@ Comment-stack:@ @[[%a]@]" - (pp_print_list - ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") - (fun fmt s -> fprintf fmt "@[`%s`@]" s)) - more ) + pf ppf ";@ Comment-stack:@ @[[%a]@]" + (list + ~sep:(fun ppf () -> pf ppf ",@ ") + (fun ppf s -> pf ppf "@[`%s`@]" s)) + more) () - |> Filename.quote - in - asprintf " printf -- '%%s\\n' %s >&2 " msg_str + |> Caml.Filename.quote in + str " printf -- '%%s\\n' %s >&2 " msg_str let one_liner = { style= `One_liner @@ -67,15 +64,12 @@ module To_posix = struct ; print_failure= failure_to_stderr } let multi_line = {one_liner with style= `Multi_line} - let default_options = one_liner let string_exn ?(options = default_options) term = let statement_separator = - match options.style with `Multi_line -> "\n" | `One_liner -> " ; " - in - let {max_argument_length; print_failure} = options in - let open Language in + match options.style with `Multi_line -> "\n" | `One_liner -> " ; " in + let {max_argument_length; print_failure; _} = options in match options.fail_with with | `Nothing -> to_shell @@ -86,13 +80,13 @@ module To_posix = struct (fun ~die -> to_shell {statement_separator; die_command= Some die; max_argument_length} - term ) + term) | `Trap_and_kill (ret, signal) -> with_die_function ~print_failure ~statement_separator ~signal_name:signal ~trap:(`Exit_with ret) (fun ~die -> to_shell {statement_separator; die_command= Some die; max_argument_length} - term ) + term) let string ?options term = match string_exn ?options term with @@ -123,17 +117,16 @@ let to_many_lines ?max_argument_length ?no_trap e = to_legacy `Multi_line ?max_argument_length ?no_trap e let quick_run_exn ?max_argument_length ?no_trap e = - match to_many_lines ?max_argument_length ?no_trap e |> Sys.command with + match to_many_lines ?max_argument_length ?no_trap e |> Caml.Sys.command with | 0 -> () - | other -> ksprintf failwith "Command returned %d" other + | other -> Fmt.failwith "Command returned %d" other let pp_hum = Language.pp - -let to_string_hum e = Format.asprintf "%a" pp_hum e +let to_string_hum e = Fmt.str "%a" pp_hum e let to_one_line_hum e = let buf = Buffer.create 42 in - let formatter = Format.formatter_of_buffer buf in - Format.pp_set_margin formatter 10_000_000 ; - Format.fprintf formatter "@[%a@]@?" pp_hum e ; + let formatter = Caml.Format.formatter_of_buffer buf in + Caml.Format.pp_set_margin formatter 10_000_000 ; + Caml.Format.fprintf formatter "@[%a@]@?" pp_hum e ; Buffer.contents buf diff --git a/src/lib/compile.mli b/src/lib/compile.mli index dce4ed6..0e90929 100644 --- a/src/lib/compile.mli +++ b/src/lib/compile.mli @@ -16,13 +16,13 @@ val to_one_line_hum : 'a EDSL.t -> string (** Compiler from {!EDSL.t} to POSIX shell scripts (one-liners or multiline scripts). *) module To_posix : sig - (** When a compiled script runs into an error, these details are - accessible to the user. *) type internal_error_details = Standard_compiler.internal_error_details = { variable: string (** The incriminated issue was stored in a shell variable. *) ; content: string (** The shell-code that produced the [variable]. *) ; code: string (** Pretty-printed version of the above EDSL code. *) } + (** When a compiled script runs into an error, these details are + accessible to the user. *) (** The kinds of messages that can be output or stored before exiting a script. *) @@ -35,12 +35,11 @@ module To_posix : sig | String_to_int_failure of internal_error_details (** {!string_to_int} can obviously fail.*) + type death_function = comment_stack:string list -> death_message -> string (** When failing (either with {!EDSL.fail} or because of internal reasons) the compiler uses a customizable function to output the “error” message and then quiting the process. *) - type death_function = comment_stack:string list -> death_message -> string - (** The potential compilation error. *) type compilation_error = Standard_compiler.compilation_error = { error: [ `No_fail_configured of death_message @@ -52,6 +51,7 @@ module To_posix : sig ; code: string option (** Chunk of relevant, pretty-printed EDSL code. *) ; comment_backtrace: string list (** Stack of `Comment` constructs at the point of the error. *) } + (** The potential compilation error. *) val pp_error : Format.formatter -> compilation_error -> unit (** Printer for error values. *) @@ -59,7 +59,6 @@ module To_posix : sig val error_to_string : compilation_error -> string (** Convenience display of error values. *) - (** Configuration of the compilation to POSIX shell scripts. *) type parameters = { style: [`Multi_line | `One_liner] (** The kind of script to output: in one-liners sequences are @@ -93,6 +92,7 @@ module To_posix : sig compiling a [unit EDSL.t] expression or what {!Sys.command} can work with. *) } + (** Configuration of the compilation to POSIX shell scripts. *) val failure_to_stderr : death_function (** The default {!death_function} just prints to [stderr]. *) diff --git a/src/lib/dune b/src/lib/dune new file mode 100644 index 0000000..d74ea15 --- /dev/null +++ b/src/lib/dune @@ -0,0 +1,8 @@ +(rule + (targets meta.ml) + (action (progn + (write-file "meta.ml" + "(** Metadata Module Generated by the Build System *)\n\nlet version = \"0.0.3-dev\"")))) +(library (name genspio) + (public_name genspio) + (libraries base fmt) ) diff --git a/src/lib/language.ml b/src/lib/language.ml index 7bd3ee9..0d04fed 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -1,7 +1,9 @@ open Common -type c_string = C_string +(* Here we use the legacy module (too much code to change at once): *) +module Format = Caml.Format +type c_string = C_string type byte_array = Byte_Array module Literal = struct @@ -11,11 +13,11 @@ module Literal = struct | Bool : bool -> bool t let pp : type a. _ -> a t -> unit = - let open Format in + let open Fmt in fun fmt -> function - | Int i -> fprintf fmt "@[(int@ %d)@]" i - | String s -> fprintf fmt "@[(string@ %S)@]" s - | Bool b -> fprintf fmt "@[(bool@ %b)@]" b + | Int i -> pf fmt "@[(int@ %d)@]" i + | String s -> pf fmt "@[(string@ %S)@]" s + | Bool b -> pf fmt "@[(bool@ %b)@]" b module Str = struct let easy_to_escape s = @@ -27,14 +29,14 @@ module Literal = struct |'/' | '#' | '@' | '!' | ' ' | '~' | '`' | '\\' | '|' | '?' | '>' |'<' | '.' | ',' | ':' | ';' | '{' | '}' | '(' | ')' | '[' | ']' -> true - | other -> false ) + | _ -> false) - let impossible_to_escape_for_variable = String.exists ~f:(( = ) '\x00') + let impossible_to_escape_for_variable = + String.exists ~f:Char.(( = ) '\x00') end end type raw_command_annotation = .. - type raw_command_annotation += Magic_unit type fd_redirection = @@ -122,8 +124,7 @@ let rec pp : type a. Format.formatter -> a t -> unit = | `Gt -> "gt" | `Ge -> "ge" | `Lt -> "lt" - | `Le -> "le" - in + | `Le -> "le" in pp_fun_call fmt sop pp [a; b] | Int_bin_op (a, op, b) -> let sop = @@ -132,11 +133,10 @@ let rec pp : type a. Format.formatter -> a t -> unit = | `Minus -> "-" | `Mult -> "×" | `Div -> "÷" - | `Mod -> "%" - in + | `Mod -> "%" in pp_fun_call fmt sop pp [a; b] | Not b -> pp_fun_call fmt "not" pp [b] - | Returns {expr; value : int} -> + | Returns {expr; value: int} -> pp_fun_call fmt (sprintf "returns-{%d}" value) pp [expr] | No_op -> fprintf fmt "(noop)" | If (c, t, e) -> @@ -150,40 +150,38 @@ let rec pp : type a. Format.formatter -> a t -> unit = let redirs fmt {take; redirect_to} = fprintf fmt "@[(%a@ >@ %a)@]" pp take (fun fmt -> function `Fd f -> fprintf fmt "%a" pp f - | `Path f -> fprintf fmt "%a" pp f ) - redirect_to - in + | `Path f -> fprintf fmt "%a" pp f) + redirect_to in pp_in_expr fmt (fun fmt () -> fprintf fmt "redirect@ %a@ %a" pp u (pp_print_list ~pp_sep:pp_print_space redirs) - l ) + l) | Write_output {expr; stdout; stderr; return_value} -> let o name fmt opt = match opt with | None -> () - | Some c -> fprintf fmt "@ @[(%s → %a)@]" name pp c - in + | Some c -> fprintf fmt "@ @[(%s → %a)@]" name pp c in pp_in_expr fmt (fun fmt () -> fprintf fmt "write-output@ %a%a%a%a" pp expr (o "stdout") stdout - (o "stderr") stderr (o "return-value") return_value ) + (o "stderr") stderr (o "return-value") return_value) | Feed (s, u) -> pp_in_expr fmt (fun fmt () -> fprintf fmt "%a@ >>@ %a" pp s pp u) | Pipe l -> pp_in_expr fmt (fun fmt () -> fprintf fmt "pipe:@ %a" (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ |@ ") pp) - l ) + l) | While {condition; body} -> pp_in_expr fmt (fun fmt () -> - fprintf fmt "while@ %a@ do:@ %a" pp condition pp body ) + fprintf fmt "while@ %a@ do:@ %a" pp condition pp body) | Fail s -> pp_in_expr fmt (fun fmt () -> fprintf fmt "FAIL@ %S" s) | Int_to_string i -> pp_fun_call fmt "int-to-string" pp [i] | String_to_int i -> pp_fun_call fmt "string-to-int" pp [i] | Bool_to_string b -> pp_fun_call fmt "bool-to-string" pp [b] | String_to_bool b -> pp_fun_call fmt "string-to-bool" pp [b] - | List_to_string (l, f) -> pp_fun_call fmt "list-to-string" pp [l] + | List_to_string (l, _) -> pp_fun_call fmt "list-to-string" pp [l] (* : 'a list t * ('a t -> byte_array t) -> byte_array t *) - | String_to_list (s, f) -> pp_fun_call fmt "string-to-list" pp [s] + | String_to_list (s, _) -> pp_fun_call fmt "string-to-list" pp [s] | List l -> pp_fun_call fmt "list" pp l | C_string_concat t -> pp_fun_call fmt "c-string-concat" pp [t] | Byte_array_concat t -> pp_fun_call fmt "byte-array-concat" pp [t] @@ -207,195 +205,116 @@ let rec pp : type a. Format.formatter -> a t -> unit = module Construct = struct let to_c_string ba = Byte_array_to_c_string ba - let to_byte_array c = C_string_to_byte_array c module C_string = struct let equals a b = String_operator (to_byte_array a, `Eq, to_byte_array b) - let ( =$= ) a b = String_operator (to_byte_array a, `Eq, to_byte_array b) - let ( <$> ) a b = String_operator (to_byte_array a, `Neq, to_byte_array b) - let to_byte_array c = C_string_to_byte_array c - let to_bytes c = C_string_to_byte_array c - let concat_elist l = C_string_concat l - let concat_list sl = concat_elist (List sl) end module Byte_array = struct let ( =$= ) a b = String_operator (a, `Eq, b) - let ( <$> ) a b = String_operator (a, `Neq, b) - let to_c_string ba = Byte_array_to_c_string ba - let to_c ba = Byte_array_to_c_string ba end module Base = struct let literal l = Literal l - let byte_array s = Literal.String s |> literal - let int s = Literal.Int s |> literal - let bool t = Literal.Bool t |> literal - let c_string s = byte_array s |> to_c_string - let string = c_string - let exec l = Exec (List.map l ~f:(fun s -> string s)) - let call l = Exec l - let ( &&& ) a b = Bool_operator (a, `And, b) - let ( ||| ) a b = Bool_operator (a, `Or, b) - let returns expr ~value = Returns {expr; value} - let succeeds expr = returns expr ~value:0 - let nop = No_op - let if_then_else a b c = If (a, b, c) - let if_then a b = if_then_else a b nop - let seq l = Seq l - let not t = Not t - let fail s = Fail s - let comment s u = Comment (s, u) - let ( %%% ) s u = comment s u - let make_switch : type a. - (bool t * unit t) list -> default:unit t -> unit t = + let make_switch : (bool t * unit t) list -> default:unit t -> unit t = fun conds ~default -> List.fold_right conds ~init:default ~f:(fun (x, body) prev -> - if_then_else x body prev ) + if_then_else x body prev) let write_output ?stdout ?stderr ?return_value expr = Write_output {expr; stdout; stderr; return_value} let write_stdout ~path expr = write_output expr ~stdout:path - let to_fd take fd = {take; redirect_to= `Fd fd} - let to_file take file = {take; redirect_to= `Path file} - let with_redirections cmd l = Redirect_output (cmd, l) - let file_exists p = call [c_string "test"; c_string "-f"; p] |> succeeds - let getenv v = Getenv v - let setenv ~var v = Setenv (var, v) - let get_stdout e = Output_as_string e - let feed ~string e = Feed (string, e) - let ( >> ) string e = feed ~string e - let pipe l = Pipe l - let ( ||> ) a b = Pipe [a; b] - let loop_while condition ~body = While {condition; body} - let loop_seq_while condition body = While {condition; body= Seq body} - let byte_array_concat_list l = Byte_array_concat l end include Base module Bool = struct - let of_string s = String_to_bool s - - let to_string b = Bool_to_string b + let of_string s = String_to_bool s let to_string b = Bool_to_string b end module Integer = struct let to_string i = Int_to_string i - let to_byte_array i = C_string_to_byte_array (Int_to_string i) - let of_string s = String_to_int s - let of_byte_array s = String_to_int (Byte_array_to_c_string s) - let bin_op a o b = Int_bin_op (a, o, b) - let add a b = bin_op a `Plus b - let ( + ) = add - let sub a b = bin_op a `Minus b - let ( - ) = sub - let mul a b = bin_op a `Mult b - let ( * ) = mul - let div a b = bin_op a `Div b - let ( / ) = div - let modulo a b = bin_op a `Mod b - let ( mod ) = modulo - let cmp op a b = Int_bin_comparison (a, op, b) - let eq = cmp `Eq - let ne = cmp `Ne - let lt = cmp `Lt - let le = cmp `Le - let ge = cmp `Ge - let gt = cmp `Gt - let ( = ) = eq - let ( <> ) = ne - let ( < ) = lt - let ( <= ) = le - let ( >= ) = ge - let ( > ) = gt end - module Magic = struct - let unit s : unit t = Raw_cmd (Some Magic_unit, s) - end + module Magic = struct let unit s : unit t = Raw_cmd (Some Magic_unit, s) end module Elist = struct let make l = List l - let append la lb = List_append (la, lb) - let iter l ~f = List_iter (l, f) - let to_string f l = List_to_string (l, f) - let of_string f l = String_to_list (l, f) let serialize_byte_array_list : byte_array list t -> byte_array t = @@ -417,7 +336,6 @@ module Construct = struct of_string Integer.of_byte_array let to_string _ = `Do_not_use - let of_string _ = `Do_not_use end end diff --git a/src/lib/standard_compiler.ml b/src/lib/standard_compiler.ml index 99ad815..3adb66d 100644 --- a/src/lib/standard_compiler.ml +++ b/src/lib/standard_compiler.ml @@ -3,8 +3,7 @@ open Common type internal_error_details = {variable: string; content: string; code: string} let pp_internal_error_details ~big_string fmt {variable; content; code} = - let open Format in - fprintf fmt "@[<2>{variable:@ %a;@ content:@ %a;@ code:@ %a}@]" big_string + Fmt.pf fmt "@[<2>{variable:@ %a;@ content:@ %a;@ code:@ %a}@]" big_string variable big_string content big_string code type death_message = @@ -12,30 +11,29 @@ type death_message = | C_string_failure of internal_error_details | String_to_int_failure of internal_error_details -let pp_death_message ?(style = `Lispy) ~big_string fmt dm = - let open Format in +let pp_death_message ?(style = `Lispy) ~big_string ppf dm = + let open Fmt in match style with | `Lispy -> ( match dm with - | User s -> fprintf fmt "@[(user@ %a)@]" big_string s + | User s -> pf ppf "@[(user@ %a)@]" big_string s | C_string_failure ied -> - fprintf fmt "@[(c-string-failure@ %a)@]" + pf ppf "@[(c-string-failure@ %a)@]" (pp_internal_error_details ~big_string) ied | String_to_int_failure ied -> - fprintf fmt "@[(string-to-int-failure@ %a)@]" + pf ppf "@[(string-to-int-failure@ %a)@]" (pp_internal_error_details ~big_string) ied ) | `User -> ( match dm with - | User s -> fprintf fmt "@[%s@]" s + | User s -> pf ppf "@[%s@]" s | C_string_failure ied -> - fprintf fmt - "@[Byte-array cannot be converted to a C-string:@ @[<2>%a@]@]" + pf ppf "@[Byte-array cannot be converted to a C-string:@ @[<2>%a@]@]" (pp_internal_error_details ~big_string) ied | String_to_int_failure ied -> - fprintf fmt "@[String cannot be converted to an Integer@ @[<2>%a@]@]" + pf ppf "@[String cannot be converted to an Integer@ @[<2>%a@]@]" (pp_internal_error_details ~big_string) ied ) @@ -55,15 +53,10 @@ type internal_representation = | Death of string let ir_unit s = Unit s - let ir_octostring s = Octostring s - let ir_int s = Int s - let ir_bool s = Bool s - let ir_death s = Death s - let ir_list s = List s let ir_to_shell = function @@ -87,35 +80,33 @@ exception Compilation of compilation_error let error ?code ~comment_backtrace error = raise (Compilation {code; comment_backtrace; error}) -let pp_error fmt {code; comment_backtrace; error} = - let open Format in +let pp_error ppf {code; comment_backtrace; error= the_error} = + let open Fmt in let summary s = - match String.sub s 0 70 with Some s -> s ^ " …" | None -> s - in - let big_string fmt s = fprintf fmt "@[%s@]" (summary s) in - fprintf fmt "@[" ; - fprintf fmt "Error:@ @[%a@];@ " - (fun fmt -> function + match String.sub s ~pos:0 ~len:70 with + | s -> s ^ " …" + | exception _ -> s in + let big_string ppf s = pf ppf "@[%s@]" (summary s) in + pf ppf "@[" ; + pf ppf "Error:@ @[%a@];@ " + (fun ppf -> function | `Max_argument_length s -> - fprintf fmt "Comand-line argument too long:@ %d bytes,@ %S." + pf ppf "Comand-line argument too long:@ %d bytes,@ %S." (String.length s) (summary s) | `Not_a_c_string s -> - fprintf fmt "String literal is not a valid/escapable C-string:@ %S." + pf ppf "String literal is not a valid/escapable C-string:@ %S." (summary s) | `No_fail_configured msg -> - fprintf fmt - "Call to `fail %a`@ while no “die” command is configured." + pf ppf "Call to `fail %a`@ while no “die” command is configured." (pp_death_message ~style:`Lispy ~big_string) - msg ) - error ; - fprintf fmt "Code:@ @[%s@];@ " + msg) + the_error ; + pf ppf "Code:@ @[%s@];@ " (match code with None -> "NONE" | Some c -> summary c) ; - fprintf fmt "Comment-backtrace:@ @[[%a]@]@ " - (pp_print_list - ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") - (fun fmt -> fprintf fmt "%S")) + pf ppf "Comment-backtrace:@ @[[%a]@]@ " + (list ~sep:(fun ppf () -> pf ppf ";@ ") (fun ppf -> pf ppf "%S")) comment_backtrace ; - fprintf fmt "@]" ; + pf ppf "@]" ; () let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = @@ -123,51 +114,44 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = let open Language in let continue_match ?add_comment e = let cmts = - match add_comment with Some c -> c :: comments | None -> comments - in - to_ir cmts params e - in + match add_comment with Some c -> c :: comments | None -> comments in + to_ir cmts params e in let continue e = continue_match e |> ir_to_shell in let seq = function | [] -> ":" - | l -> String.concat ~sep:params.statement_separator l - in + | l -> String.concat ~sep:params.statement_separator l in let die s = match params.die_command with | Some f -> f ~comment_stack:comments s - | None -> error ~comment_backtrace:comments (`No_fail_configured s) - in + | None -> error ~comment_backtrace:comments (`No_fail_configured s) in let expand_octal s = - sprintf + Fmt.str {sh| printf -- "$(printf -- '%%s\n' %s | sed -e 's/\(.\{3\}\)/\\\1/g')" |sh} - s - in + s in let to_argument ~error_loc varprefix = let argument ?declaration ?variable_name argument = object method declaration = declaration - method export = Option.map ~f:(sprintf "export %s ; ") declaration + method export = Option.map ~f:(Fmt.str "export %s ; ") declaration method variable_name = variable_name method argument = argument - end - in + end in let check_length s = match params.max_argument_length with | None -> s | Some m when String.length s > m -> error ~comment_backtrace:comments (`Max_argument_length s) - ~code:(Format.asprintf "%a" pp error_loc) - | Some _ -> s - in + ~code:(Fmt.str "%a" pp error_loc) + | Some _ -> s in function | `C_string (c_str : c_string t) -> ( match c_str with | Byte_array_to_c_string (Literal (Literal.String s)) when Literal.Str.easy_to_escape s -> - argument (Filename.quote s |> check_length) + argument (Caml.Filename.quote s |> check_length) | Byte_array_to_c_string (Literal (Literal.String s)) when Literal.Str.impossible_to_escape_for_variable s -> error ~comment_backtrace:comments (`Not_a_c_string s) @@ -175,41 +159,37 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = | other -> let variable_name = Unique_name.variable varprefix in let declaration = - sprintf "%s=$(%s; printf 'x')" variable_name - (continue other |> expand_octal |> check_length) - in + Fmt.str "%s=$(%s; printf 'x')" variable_name + (continue other |> expand_octal |> check_length) in argument ~variable_name ~declaration - (sprintf "\"${%s%%?}\"" variable_name) ) + (Fmt.str "\"${%s%%?}\"" variable_name) ) | `Int (Literal (Literal.Int s)) -> argument (Int.to_string s) | `Int other -> let variable_name = Unique_name.variable varprefix in let declaration = - sprintf "%s=%s" variable_name (continue other |> check_length) - in + Fmt.str "%s=%s" variable_name (continue other |> check_length) in argument ~variable_name ~declaration - (sprintf "\"${%s%%?}\"" variable_name) - in + (Fmt.str "\"${%s%%?}\"" variable_name) in match e with | Exec l -> let variables = ref [] in let args = List.mapi l ~f:(fun index v -> - let varname = sprintf "argument_%d" index in + let varname = Fmt.str "argument_%d" index in let arg = to_argument ~error_loc:e varname (`C_string v) in match arg#declaration with | None -> arg#argument | Some vardef -> - variables := sprintf "%s ; " vardef :: !variables ; - arg#argument ) - in + variables := Fmt.str "%s ; " vardef :: !variables ; + arg#argument) in List.rev !variables @ args - |> String.concat ~sep:" " |> sprintf " { %s ; } " |> ir_unit + |> String.concat ~sep:" " |> Fmt.str " { %s ; } " |> ir_unit | Raw_cmd (_, s) -> s |> ir_unit | Byte_array_to_c_string ba -> let bac = continue ba in let var = Unique_name.variable "byte_array_to_c_string" in - let value = sprintf "\"$%s\"" var in - let value_n = sprintf "\"$%s\\n\"" var in + let value = Fmt.str "\"$%s\"" var in + let value_n = Fmt.str "\"$%s\\n\"" var in (* We store the internal octal representation in a variable, then we use `sed` to check that there are no `'\000'` characters. If OK we re-export with printf, if not we fail hard. @@ -217,52 +197,49 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = BSD-ish `sed`s do not support “or”s in regular expressions. Cf. http://pubs.opengroup.org/onlinepubs/9699919799/utilities/sed.html *) - sprintf "\"$(%s ; )\"" + Fmt.str "\"$(%s ; )\"" @@ seq - [ sprintf " %s=%s" var bac - ; sprintf + [ Fmt.str " %s=%s" var bac + ; Fmt.str {sh|if [ "$(printf -- %s | sed -e 's/\(.\{3\}\)/@\1/g' | grep @000)" = "" ] |sh} value_n - ; sprintf "then printf -- %s" value - ; sprintf "else %s" + ; Fmt.str "then printf -- %s" value + ; Fmt.str "else %s" (die (C_string_failure - { variable= var - ; content= bac - ; code= Format.asprintf "%a" pp ba })) - ; (* (sprintf "Byte_array_to_c_string: error, $%s is not a C string" *) - (* var)); *) - "fi" ] + {variable= var; content= bac; code= Fmt.str "%a" pp ba})) + ; (* (Fmt.str "Byte_array_to_c_string: error, $%s is not a C string" *) + (* var)); *) "fi" ] |> ir_octostring | C_string_to_byte_array c -> continue c |> ir_octostring | Returns {expr; value} -> - sprintf " { %s ; [ $? -eq %d ] ; }" (continue expr) value |> ir_bool + Fmt.str " { %s ; [ $? -eq %d ] ; }" (continue expr) value |> ir_bool | Bool_operator (a, op, b) -> - sprintf "{ %s %s %s ; }" (continue a) + Fmt.str "{ %s %s %s ; }" (continue a) (match op with `And -> "&&" | `Or -> "||") (continue b) |> ir_bool | String_operator (a, op, b) -> - sprintf "[ \"%s\" %s \"%s\" ]" (continue a) + Fmt.str "[ \"%s\" %s \"%s\" ]" (continue a) (match op with `Eq -> "=" | `Neq -> "!=") (continue b) |> ir_bool | No_op -> ":" |> ir_unit | If (c, t, e) -> seq - [ sprintf "if { %s ; }" (continue c) - ; sprintf "then %s" (continue t) - ; sprintf "else %s" (continue e) + [ Fmt.str "if { %s ; }" (continue c) + ; Fmt.str "then %s" (continue t) + ; Fmt.str "else %s" (continue e) ; "fi" ] |> ir_unit | While {condition; body} -> seq - [ sprintf "while { %s ; }" (continue condition) - ; sprintf "do %s" (continue body) + [ Fmt.str "while { %s ; }" (continue condition) + ; Fmt.str "do %s" (continue body) ; "done" ] |> ir_unit | Seq l -> seq (List.map l ~f:continue) |> ir_unit - | Not t -> sprintf "! { %s ; }" (continue t) |> ir_bool + | Not t -> Fmt.str "! { %s ; }" (continue t) |> ir_bool | Redirect_output (unit_t, redirections) -> (* We're here compiling the redirections into `exec` statements which @@ -271,85 +248,76 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = ( exec 3>/tmp/output-of-ls ; exec 2>&3 ; exec 1>&2 ; ls ; ) ; *) let make_redirection {take; redirect_to} = - let takearg = - to_argument ~error_loc:e "redirection_take" (`Int take) - in + let takearg = to_argument ~error_loc:e "redirection_take" (`Int take) in let retoarg = to_argument ~error_loc:e "redirection_to" (match redirect_to with `Fd i -> `Int i | `Path p -> `C_string p) in let variables = [takearg#export; retoarg#export] |> List.filter_opt in let exec = - sprintf "\"exec %%s>%s%%s\" %s %s" + Fmt.str "\"exec %%s>%s%%s\" %s %s" (match redirect_to with `Fd _ -> "&" | `Path _ -> "") - takearg#argument retoarg#argument - in - sprintf + takearg#argument retoarg#argument in + Fmt.str "%s eval \"$(printf -- %s)\" || { echo 'Exec %s failed' >&2 ; } " (String.concat variables ~sep:"") - exec exec - in + exec exec in ( match redirections with | [] -> continue unit_t | one :: more -> continue (Seq - ( Raw_cmd (None, sprintf "( %s" (make_redirection one)) + ( Raw_cmd (None, Fmt.str "( %s" (make_redirection one)) :: List.map more ~f:(fun r -> - Raw_cmd (None, make_redirection r) ) + Raw_cmd (None, make_redirection r)) @ [unit_t] @ [Raw_cmd (None, ")")] )) ) |> ir_unit | Write_output {expr; stdout; stderr; return_value} -> let ret_arg = Option.map return_value ~f:(fun v -> - to_argument ~error_loc:e "retval" (`C_string v) ) - in + to_argument ~error_loc:e "retval" (`C_string v)) in let var = - Option.(ret_arg >>= (fun ra -> ra#export) |> value ~default:"") - in + Option.(ret_arg >>= (fun ra -> ra#export) |> value ~default:"") in let with_potential_return = - sprintf "%s { %s %s ; }" var (continue expr) + Fmt.str "%s { %s %s ; }" var (continue expr) (Option.value_map ret_arg ~default:"" ~f:(fun r -> - sprintf "; printf -- \"$?\" > %s" r#argument )) - in + Fmt.str "; printf -- \"$?\" > %s" r#argument)) in let redirections = let make fd = - Option.map ~f:(fun p -> {take= Construct.int fd; redirect_to= `Path p} - ) - in - [make 1 stdout; make 2 stderr] |> List.filter_opt - in + Option.map ~f:(fun p -> + {take= Construct.int fd; redirect_to= `Path p}) in + [make 1 stdout; make 2 stderr] |> List.filter_opt in continue (Redirect_output (Raw_cmd (None, with_potential_return), redirections)) |> ir_unit | Literal lit -> ( let open Literal in match lit with - | Int i -> sprintf "%d" i |> ir_int + | Int i -> Fmt.str "%d" i |> ir_int | String s -> with_buffer (fun str -> - String.iter s ~f:(fun c -> Char.code c |> sprintf "%03o" |> str) - ) + String.iter s ~f:(fun c -> + Char.to_int c |> Fmt.str "%03o" |> str)) |> fst |> ir_octostring | Bool true -> ir_bool "true" | Bool false -> ir_bool "false" ) | Output_as_string e -> - sprintf "\"$( { %s ; } | od -t o1 -An -v | tr -d ' \\n' )\"" (continue e) + Fmt.str "\"$( { %s ; } | od -t o1 -An -v | tr -d ' \\n' )\"" (continue e) |> ir_octostring | Int_to_string i -> continue (Output_as_string - (Raw_cmd (None, sprintf "printf -- '%%d' %s" (continue i)))) + (Raw_cmd (None, Fmt.str "printf -- '%%d' %s" (continue i)))) |> ir_octostring | String_to_int s -> let var = Unique_name.variable "string_to_int" in - let value = sprintf "\"$%s\"" var in + let value = Fmt.str "\"$%s\"" var in let content = continue s |> expand_octal in (* We put the result of the string expression in a variable to evaluate it once; then we test that the result is an integer (i.e. ["test ... -eq ...."] parses it as an integer). *) - sprintf + Fmt.str " $( %s=$( %s ) ; if [ %s -eq %s ] ; then printf -- %s ; else %s ; fi \ ; ) " var content value value value @@ -362,7 +330,7 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = (Output_as_string (Raw_cmd ( None - , sprintf + , Fmt.str "{ if %s ; then printf true ; else printf false ; fi ; }" (continue b) ))) |> ir_octostring @@ -378,48 +346,47 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = , `Eq , Literal (Literal.String "false") ) , Raw_cmd (None, "false") - , Fail (sprintf "String_to_bool") ) )) + , Fail (Fmt.str "String_to_bool") ) )) |> ir_bool | List l -> (* Lists are space-separated internal represetations, prefixed by `G`. *) - let output o = sprintf "printf -- 'G%%s' \"%s\"" (continue o) in + let output o = Fmt.str "printf -- 'G%%s' \"%s\"" (continue o) in let outputs = List.map l ~f:output in let rec build = function | [] -> [] | [one] -> [one] - | one :: two :: t -> one :: "printf -- ' '" :: build (two :: t) - in + | one :: two :: t -> one :: "printf -- ' '" :: build (two :: t) in seq (build outputs) |> ir_list - | List_to_string (l, f) -> + | List_to_string (l, _) -> continue (Output_as_string (Raw_cmd (None, continue l))) |> ir_octostring - | String_to_list (s, f) -> + | String_to_list (s, _) -> continue s |> expand_octal - |> sprintf "printf -- '%%s' \"$(%s)\"" + |> Fmt.str "printf -- '%%s' \"$(%s)\"" |> ir_list | C_string_concat sl -> let outputing_list = continue sl in - sprintf "$( { %s ; } | tr -d 'G ' )" outputing_list |> ir_octostring + Fmt.str "$( { %s ; } | tr -d 'G ' )" outputing_list |> ir_octostring | Byte_array_concat sl -> let outputing_list = continue sl in - sprintf "$( { %s ; } | tr -d 'G ' )" outputing_list |> ir_octostring + Fmt.str "$( { %s ; } | tr -d 'G ' )" outputing_list |> ir_octostring | List_append (la, lb) -> seq [continue la; "printf -- ' '"; continue lb] |> ir_list | List_iter (l, f) -> let variter = Unique_name.variable "list_iter_var" in let outputing_list = continue l in seq - [ sprintf "for %s in $(%s) " variter outputing_list + [ Fmt.str "for %s in $(%s) " variter outputing_list ; "do : " ; (* we cannot put a `;` after do so the first command is no-op *) continue (f (fun () -> (* Here we remove the `G` from the internal represetation: *) - Raw_cmd (None, sprintf "${%s#G}" variter) )) + Raw_cmd (None, Fmt.str "${%s#G}" variter))) ; "done" ] |> ir_unit | Int_bin_op (ia, op, ib) -> - sprintf "$(( %s %s %s ))" (continue ia) + Fmt.str "$(( %s %s %s ))" (continue ia) ( match op with | `Div -> "/" | `Minus -> "-" @@ -429,7 +396,7 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = (continue ib) |> ir_int | Int_bin_comparison (ia, op, ib) -> - sprintf "[ %s %s %s ]" (continue ia) + Fmt.str "[ %s %s %s ]" (continue ia) ( match op with | `Eq -> "-eq" | `Ge -> "-ge" @@ -440,17 +407,17 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = (continue ib) |> ir_int | Feed (string, e) -> - sprintf {sh| %s | %s |sh} + Fmt.str {sh| %s | %s |sh} (continue string |> expand_octal) (continue e) |> ir_unit | Pipe [] -> ":" |> ir_unit | Pipe l -> - sprintf " %s " (List.map l ~f:continue |> String.concat ~sep:" | ") + Fmt.str " %s " (List.map l ~f:continue |> String.concat ~sep:" | ") |> ir_unit | Getenv s -> let var = Unique_name.variable "getenv" in - let value = sprintf "\"$%s\"" var in + let value = Fmt.str "\"$%s\"" var in let cmd_outputs_value = (* We need to get the output of the `string t` and then do a `$` on it: @@ -460,17 +427,16 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = just “cuts” it, it wouldn't fail and `${HOME\nBOUH}` would be equal to `${HOME}` *) - sprintf + Fmt.str "{ %s=$(printf \\\"\\${%%s}\\\" $(%s | tr -d '\\n')) ; eval \ \"printf -- '%%s' %s\" ; } " var (continue s |> expand_octal) - value - in + value in continue (Output_as_string (Raw_cmd (None, cmd_outputs_value))) |> ir_octostring | Setenv (variable, value) -> - sprintf "export $(%s)=\"$(%s)\"" + Fmt.str "export $(%s)=\"$(%s)\"" (continue variable |> expand_octal) (continue value |> expand_octal) |> ir_unit @@ -478,7 +444,7 @@ let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = | Comment (cmt, expr) -> ( match continue_match ~add_comment:cmt expr with | Unit u -> - sprintf " { %s ; %s ; }" Construct.(exec [":"; cmt] |> continue) u + Fmt.str " { %s ; %s ; }" Construct.(exec [":"; cmt] |> continue) u |> ir_unit | (Octostring _ | Int _ | Bool _ | List _ | Death _) as d -> d ) @@ -494,11 +460,10 @@ let with_die_function ~print_failure ~statement_separator ~signal_name let variable_name = Unique_name.variable "genspio_trap" in let die ~comment_stack s = let pr = print_failure ~comment_stack s in - sprintf " { %s ; kill -s %s ${%s} ; } " pr signal_name variable_name - in + Fmt.str " { %s ; kill -s %s ${%s} ; } " pr signal_name variable_name in String.concat ~sep:statement_separator - [ sprintf "export %s=$$" variable_name + [ Fmt.str "export %s=$$" variable_name ; ( match trap with - | `Exit_with ex -> sprintf "trap 'exit %d' %s" ex signal_name + | `Exit_with ex -> Fmt.str "trap 'exit %d' %s" ex signal_name | `None -> ": 'No Trap'" ) ; script ~die ] diff --git a/src/lib/to_slow_flow.ml b/src/lib/to_slow_flow.ml index 5cc58d9..4af3c39 100644 --- a/src/lib/to_slow_flow.ml +++ b/src/lib/to_slow_flow.ml @@ -22,11 +22,11 @@ let string_to_octal ?(prefix = "") s = with_buffer (fun str -> String.iter s ~f:(fun c -> str prefix ; - Char.code c |> sprintf "%03o" |> str ) ) + Char.to_int c |> Fmt.str "%03o" |> str)) |> fst let expand_octal_command ~remove_l s = - sprintf + Fmt.str {sh| printf -- "$(printf -- '%%s\n' %s %s | sed -e 's/\(.\{3\}\)/\\\1/g')" |sh} s (if remove_l then "| tr -d L" else "") @@ -34,11 +34,12 @@ let expand_octal_command ~remove_l s = let m = ref 0 let var_name ?expression ?script tag = - incr m ; + Caml.incr m ; let stag = String.map tag ~f:(function '-' -> '_' | a -> a) in - sprintf "genspio_%s_%d_%d_%s" stag (Random.int 100_000_000) !m - ( Marshal.to_string (expression, script) [Marshal.Closures] - |> Digest.string |> Digest.to_hex ) + Fmt.str "genspio_%s_%d_%d_%s" stag (Random.int 100_000_000) !m + Caml.( + Marshal.to_string (expression, script) [Marshal.Closures] + |> Digest.string |> Digest.to_hex) module Tmp_db = struct type t = @@ -49,9 +50,8 @@ module Tmp_db = struct let make ?(deletion_grouping = 20) how = let default_tmpdir = match how with - | `Fresh -> Filename.concat "/tmp" (var_name "tmpdir") - | `Use p -> p - in + | `Fresh -> Caml.Filename.concat "/tmp" (var_name "tmpdir") + | `Use p -> p in {default_tmpdir; tmp_file_db= []; deletion_grouping} let register_file t ~variable ~directory = @@ -64,17 +64,17 @@ module Tmp_db = struct | [] -> [] | l -> let tk, nxt = List.split_n l t.deletion_grouping in - sprintf "rm -f %s" - ( List.map tk ~f:(fun (v, _) -> sprintf "\"${%s}\"" v) + Fmt.str "rm -f %s" + ( List.map tk ~f:(fun (v, _) -> Fmt.str "\"${%s}\"" v) |> String.concat ~sep:" " ) - :: unroll nxt - in - sprintf "%s () {\n: Deleting all the temporary files:\n%s\n}" delete_fname - @@ String.concat ~sep:"\n" (unroll (List.dedup t.tmp_file_db)) + :: unroll nxt in + Fmt.str "%s () {\n: Deleting all the temporary files:\n%s\n}" delete_fname + @@ String.concat ~sep:"\n" + (unroll (List.dedup_and_sort t.tmp_file_db ~compare:Poly.compare)) let tmp_vars t = - List.map (List.dedup t.tmp_file_db) ~f:(fun (v, dir) -> - (v, dir, sprintf "%s=%s/tmp-%s" v dir v) ) + List.map (List.dedup_and_sort t.tmp_file_db ~compare:Poly.compare) + ~f:(fun (v, dir) -> (v, dir, Fmt.str "%s=%s/tmp-%s" v dir v)) end (*md @@ -92,9 +92,7 @@ module Script = struct | Comment of string | Redirect of {block: command list; stdout: compiled_value} | If_then_else of - { condition: string - ; block_then: command list - ; block_else: command list } + {condition: string; block_then: command list; block_else: command list} | While of {condition: string; block: command list} | Sub_shell of command list (* As is in `( ... ; )` in POSIX shells. *) @@ -124,25 +122,25 @@ quoting. See the ``| Int_bin_op (ia, op, ib) ->`` case below, *) let to_argument ?(arithmetic = false) = function | Unit -> "\"$(exit 42)\"" - | Literal_value s when String.exists s ~f:(( = ) '\x00') -> + | Literal_value s when String.exists s ~f:Char.(( = ) '\x00') -> let oct = string_to_octal s in - let v = sprintf "$(%s)" (expand_octal_command ~remove_l:false oct) in - if not arithmetic then sprintf "\"%s\"" v else v + let v = Fmt.str "$(%s)" (expand_octal_command ~remove_l:false oct) in + if not arithmetic then Fmt.str "\"%s\"" v else v | Literal_value s -> - let v = Filename.quote s in - if arithmetic then sprintf "$(printf -- %s)" v else v + let v = Caml.Filename.quote s in + if arithmetic then Fmt.str "$(printf -- %s)" v else v | File s -> - let v = sprintf "$(cat %s)" (Filename.quote s) in - if not arithmetic then sprintf "\"%s\"" v else v + let v = Fmt.str "$(cat %s)" (Caml.Filename.quote s) in + if not arithmetic then Fmt.str "\"%s\"" v else v | Tmp_file_in_variable s -> (* Parameters.(tmp_file_db := s :: !tmp_file_db) ; *) - let v = sprintf "$(cat ${%s})" s in - if not arithmetic then sprintf "\"%s\"" v else v + let v = Fmt.str "$(cat ${%s})" s in + if not arithmetic then Fmt.str "\"%s\"" v else v | Raw_inline s when not arithmetic -> s - | Raw_inline s -> sprintf "$(printf -- '%%s' %s)" s + | Raw_inline s -> Fmt.str "$(printf -- '%%s' %s)" s | Octal_value_in_variable var -> - (if arithmetic then sprintf "$(%s)" else sprintf "\"$(%s)\"") - (expand_octal_command ~remove_l:true (sprintf "${%s}" var)) + (if arithmetic then Fmt.str "$(%s)" else Fmt.str "\"$(%s)\"") + (expand_octal_command ~remove_l:true (Fmt.str "${%s}" var)) (*md @@ -157,23 +155,24 @@ In that case, we compare the octal representations. | Raw_inline s -> s | Literal_value s -> string_to_octal s | File f -> - sprintf "$(cat %s | od -t o1 -An -v | tr -d ' \\n')" (Filename.quote f) + Fmt.str "$(cat %s | od -t o1 -An -v | tr -d ' \\n')" + (Caml.Filename.quote f) | Tmp_file_in_variable f -> (* Parameters.(tmp_file_db := f :: !tmp_file_db) ; *) - sprintf "$(cat \"${%s}\" | od -t o1 -An -v | tr -d ' \\n')" f - | Octal_value_in_variable var -> sprintf "${%s}" var + Fmt.str "$(cat \"${%s}\" | od -t o1 -An -v | tr -d ' \\n')" f + | Octal_value_in_variable var -> Fmt.str "${%s}" var let commands s = s.commands let to_path_argument = function | Unit -> assert false | Raw_inline s -> s - | Literal_value s -> assert false - | File f -> Filename.quote f + | Literal_value _ -> assert false + | File f -> Caml.Filename.quote f | Tmp_file_in_variable f -> (* Parameters.(tmp_file_db := f :: !tmp_file_db) ; *) - sprintf "\"${%s}\"" f - | Octal_value_in_variable var -> assert false + Fmt.str "\"${%s}\"" f + | Octal_value_in_variable _ -> assert false (*md @@ -193,8 +192,8 @@ In that case, we compare the octal representations. | Raw s -> fprintf fmt "%s" s | Comment s -> fprintf fmt "%s" - ( String.split ~on:(`Character '\n') s - |> List.map ~f:(sprintf "## %s") + ( String.split ~on:'\n' s + |> List.map ~f:(Fmt.str "## %s") |> String.concat ~sep:"\n" ) | Redirect {block; stdout} -> fprintf fmt ": redirect ; %a > %s" pp_block block @@ -211,7 +210,7 @@ In that case, we compare the octal representations. fprintf fmt "%a" (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt " | ") pp_block) blocks - | Make_directory f when List.mem ~set:!mkdir_done f -> () + | Make_directory f when List.mem !mkdir_done f ~equal:Poly.equal -> () | Make_directory f -> mkdir_done := f :: !mkdir_done ; fprintf fmt "mkdir -p %s" f @@ -224,22 +223,16 @@ In that case, we compare the octal representations. | File s -> fprintf fmt "File: %S" s | Tmp_file_in_variable s -> fprintf fmt "File: ${%s}" s | Raw_inline s -> fprintf fmt "Raw: %S" s - | Octal_value_in_variable var -> fprintf fmt "Octal in $%s" var - in + | Octal_value_in_variable var -> fprintf fmt "Octal in $%s" var in fprintf fmt "%a\n# Result: %a\n" pp_command_list script.commands pp_result script.result - let rawf fmt = ksprintf (fun s -> Raw s) fmt - - let cmtf fmt = ksprintf (fun s -> Comment s) fmt - + let rawf fmt = Fmt.kstr (fun s -> Raw s) fmt + let cmtf fmt = Fmt.kstr (fun s -> Comment s) fmt let make commands result = {commands; result} - let unit commands = make commands Unit - let literal_value v = make [] (Literal_value v) - - let assert_unit s = assert (s.result = Unit) + let assert_unit s = assert (Poly.(s.result = Unit)) let redirect ~stdout block = { stdout with @@ -247,7 +240,7 @@ In that case, we compare the octal representations. let mktmp ~tmpdb ?expression ?script tag = let v = var_name ?expression ?script tag in - let dir = sprintf "\"${TMPDIR:-%s}\"" (Tmp_db.default_tmpdir tmpdb) in + let dir = Fmt.str "\"${TMPDIR:-%s}\"" (Tmp_db.default_tmpdir tmpdb) in Tmp_db.register_file tmpdb ~variable:v ~directory:dir ; make [] (Tmp_file_in_variable v) @@ -263,8 +256,7 @@ In that case, we compare the octal representations. let commands = cond.commands @ [ If_then_else - {condition; block_then= t.commands; block_else= e.commands} ] - in + {condition; block_then= t.commands; block_else= e.commands} ] in make commands Unit let if_then cond t = @@ -286,23 +278,22 @@ In that case, we compare the octal representations. | Literal_value "false" -> (Literal_value "true", []) | Literal_value s -> (Literal_value s, []) (* This should just be an error later *) - | Raw_inline s -> (Raw_inline (sprintf "! %s" s), []) + | Raw_inline s -> (Raw_inline (Fmt.str "! %s" s), []) | (Tmp_file_in_variable _ | File _ | Octal_value_in_variable _) as p -> ( tmp.result , tmp.commands @ [ If_then_else { condition= to_argument p ; block_then= bool_to_file false tmp.result - ; block_else= bool_to_file true tmp.result } ] ) - in + ; block_else= bool_to_file true tmp.result } ] ) in {commands= commands @ morecmds; result= r} - let return_value_to_bool ~tmp {commands; result} v = + let return_value_to_bool ~tmp {commands; _} v = { tmp with commands= tmp.commands @ commands @ [ If_then_else - { condition= sprintf " [ $? -eq %d ]" v + { condition= Fmt.str " [ $? -eq %d ]" v ; block_then= bool_to_file true tmp.result ; block_else= bool_to_file false tmp.result } ] } @@ -346,11 +337,9 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let loop = [ rawf "rm -f %s ; touch %s ; for %s in $(cat %s) ; do %s >> %s\ndone" tmppatharg tmppatharg file_var list_file - (expand_octal_command ~remove_l:true (sprintf "${%s}" file_var)) - tmppatharg ] - in - make (tmp.commands @ sl_script.commands @ loop) tmp.result - in + (expand_octal_command ~remove_l:true (Fmt.str "${%s}" file_var)) + tmppatharg ] in + make (tmp.commands @ sl_script.commands @ loop) tmp.result in let result_to_file s = let open Script in (* let tmp = tmp_path ~tmpdb ~expression:e ~script:s "result-to-file" in *) @@ -359,24 +348,22 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let mk (cmd, res) = Script.make (res.commands @ [cmd]) res.result in match s.result with | Unit -> mk (rawf "echo '' > %s" tmparg, tmp) - | Literal_value v when String.exists v ~f:(( = ) '\x00') -> + | Literal_value v when String.exists v ~f:Char.(( = ) '\x00') -> let esc = string_to_octal v ~prefix:"\\" in mk (rawf "printf -- '%s' > %s" esc tmparg, tmp) | Literal_value v -> - mk (rawf "printf -- '%%s' %s > %s" (Filename.quote v) tmparg, tmp) + mk (rawf "printf -- '%%s' %s > %s" (Caml.Filename.quote v) tmparg, tmp) | File p -> mk (rawf ":", make [] (File p)) | Tmp_file_in_variable p -> mk (rawf "cp \"${%s}\" %s" p tmparg, tmp) | Raw_inline s -> mk (rawf "printf -- '%%s' %s > %s" s tmparg, tmp) | Octal_value_in_variable _ as v -> - mk (rawf "printf -- '%%s' %s > %s" (to_argument v) tmparg, tmp) - in + mk (rawf "printf -- '%%s' %s > %s" (to_argument v) tmparg, tmp) in match e with | Exec l -> let irs = List.map ~f:continue l in let cmd = String.concat ~sep:" " - (List.map ~f:(fun c -> Script.to_argument c.result) irs) - in + (List.map ~f:(fun c -> Script.to_argument c.result) irs) in let commands = List.concat_map ~f:Script.commands irs in Script.unit (commands @ [Raw cmd]) | Raw_cmd (Some Magic_unit, s) -> Script.unit [Script.rawf "%s" s] @@ -389,37 +376,36 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let extra_check = match script.result with | Unit -> assert false - | Literal_value li when String.exists li ~f:(( = ) '\x00') -> + | Literal_value li when String.exists li ~f:Char.(( = ) '\x00') -> fail_commands "Cannot convert literal %S to C-String" - | Literal_value li -> [] + | Literal_value _ -> [] | File f -> [ If_then_else { condition= - sprintf + Fmt.str "od -t o1 -An -v %s | grep ' 000' > /dev/null 2>&1 " f ; block_then= - ksprintf fail_commands + Fmt.kstr fail_commands "Byte array in %s cannot be converted to a C-String" f ; block_else= [] } ] | Tmp_file_in_variable v -> [ If_then_else { condition= - sprintf + Fmt.str "od -t o1 -An -v ${%s} | grep ' 000' > /dev/null 2>&1 " v ; block_then= - ksprintf fail_commands + Fmt.kstr fail_commands "Byte array in $%s cannot be converted to a C-String" v ; block_else= [] } ] - | Raw_inline ri -> [] + | Raw_inline _ -> [] | Octal_value_in_variable v -> [ If_then_else { condition= - sprintf "echo ${%s} | grep ' 000' > /dev/null 2>&1 " v + Fmt.str "echo ${%s} | grep ' 000' > /dev/null 2>&1 " v ; block_then= - ksprintf fail_commands + Fmt.kstr fail_commands "Byte array in $%s cannot be converted to a C-String" v - ; block_else= [] } ] - in + ; block_else= [] } ] in make (script.commands @ extra_check) script.result | C_string_to_byte_array c -> continue c | Returns {expr; value} -> @@ -432,9 +418,8 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let ops = match op with `And -> "&&" | `Or -> "||" in let open Script in let condition = - sprintf "{ %s %s %s ; }" (to_argument asc.result) ops - (to_argument bsc.result) - in + Fmt.str "{ %s %s %s ; }" (to_argument asc.result) ops + (to_argument bsc.result) in let tmp = mktmp ~tmpdb ~expression:e "boolop" in make_bool ~tmp ~condition (asc.commands @ bsc.commands) | String_operator (a, op, b) -> @@ -443,9 +428,8 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let ops = match op with `Eq -> "=" | `Neq -> "!=" in let open Script in let condition = - sprintf "[ \"%s\" %s \"%s\" ]" (to_ascii asc.result) ops - (to_ascii bsc.result) - in + Fmt.str "[ \"%s\" %s \"%s\" ]" (to_ascii asc.result) ops + (to_ascii bsc.result) in let tmp = mktmp ~tmpdb ~expression:e "boolop" in make_bool ~tmp ~condition (asc.commands @ bsc.commands) | No_op -> Script.unit [Raw ":"] @@ -468,8 +452,7 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = match s.result with | Unit -> Script.commands s | Raw_inline cmd -> Script.(Raw cmd :: commands s) - | other -> assert false ) - in + | _ -> assert false) in Script.unit cmds | Not t -> Script.bool_not @@ -484,16 +467,13 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let redirect_to_script, op = match redirect_to with | `Fd c -> (continue c, "&") - | `Path p -> (continue p, "") - in + | `Path p -> (continue p, "") in let print_exec_command = - sprintf "printf 'exec %%s>%s%%s' %s %s" op + Fmt.str "printf 'exec %%s>%s%%s' %s %s" op (to_argument take_script.result) - (to_argument redirect_to_script.result) - in + (to_argument redirect_to_script.result) in ( precmds @ take_script.commands @ redirect_to_script.commands - , evals @ [rawf "eval $(%s)" print_exec_command] ) ) - in + , evals @ [rawf "eval $(%s)" print_exec_command] )) in let uscript = continue unit_t in Script.assert_unit uscript ; Script.sub_shell ~pre:pre_commands (sub_shell_commands @ uscript.commands) @@ -510,28 +490,24 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = ( "Writing return value" , Raw_cmd ( None - , sprintf "printf -- \"$?\" > %s" - Script.(to_argument scr.result) ) ) ] ) - in + , Fmt.str "printf -- \"$?\" > %s" + Script.(to_argument scr.result) ) ) ] ) in let redirections = let make fd = - Option.map ~f:(fun p -> {take= Construct.int fd; redirect_to= `Path p} - ) - in - [make 1 stdout; make 2 stderr] |> List.filter_opt - in + Option.map ~f:(fun p -> + {take= Construct.int fd; redirect_to= `Path p}) in + [make 1 stdout; make 2 stderr] |> List.filter_opt in let redscript = - continue (Redirect_output (with_potential_return, redirections)) - in + continue (Redirect_output (with_potential_return, redirections)) in Script.assert_unit redscript ; Script.unit (pre_ret_value @ redscript.commands) | Literal lit -> Script.literal_value Literal.( match lit with - | Int i -> string_of_int i + | Int i -> Int.to_string i | String s -> s - | Bool s -> string_of_bool s) + | Bool s -> Bool.to_string s) | Output_as_string e -> let open Script in let ir = continue e in @@ -551,8 +527,7 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = , `Eq , Raw_cmd (None, to_argument string_script.result) ) , No_op - , Fail "string-to-int" )) - in + , Fail "string-to-int" )) in make (string_script.commands @ check.commands) string_script.result | Bool_to_string b -> let open Script in @@ -563,9 +538,8 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = If_then_else { condition= to_argument bs.result ; block_then= [rawf "printf true > %s" tmparg] - ; block_else= [rawf "printf false > %s" tmparg] } - in - bs.commands @ [extra] ) + ; block_else= [rawf "printf false > %s" tmparg] } in + bs.commands @ [extra]) | String_to_bool s -> let scr = continue s in let extra_check = @@ -573,14 +547,12 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = String_operator ( Raw_cmd (None, Script.to_ascii scr.result) , `Eq - , Literal Literal.(String v) ) - in + , Literal Literal.(String v) ) in If ( Bool_operator (is "true", `Or, is "false") , No_op - , Fail (sprintf "String-to-Bool: %S" (Script.to_argument scr.result)) - ) - in + , Fail (Fmt.str "String-to-Bool: %S" (Script.to_argument scr.result)) + ) in let check = continue extra_check in Script.make (scr.commands @ check.commands) scr.result | List l -> @@ -607,11 +579,10 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = @ [ rawf "printf ' L%%s\\n' \"$(cat %s | od -t o1 -An -v | \ tr -d ' \\n')\" >> %s" - as_arg tmparg ] ) ) - in - List.concat_map scripts ~f:(fun c -> c.commands) @ echos ) - | List_to_string (l, f) -> continue l - | String_to_list (s, f) -> continue s + as_arg tmparg ]) ) in + List.concat_map scripts ~f:(fun c -> c.commands) @ echos) + | List_to_string (l, _) -> continue l + | String_to_list (s, _) -> continue s | C_string_concat sl -> let sl_script = continue sl in concat_string_list sl_script @@ -627,9 +598,8 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = rawf "cat %s %s > %s" (to_path_argument a_script.result) (to_path_argument b_script.result) - (to_path_argument tmp.result) - in - a_script.commands @ b_script.commands @ [cat] ) + (to_path_argument tmp.result) in + a_script.commands @ b_script.commands @ [cat]) | List_iter (l, f) -> let open Script in let l_script = continue l in @@ -643,13 +613,11 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = (f (fun () -> Raw_cmd ( Some (Octal_in_variable file_var) - , "=== This should never be used ===" ) )) - in + , "=== This should never be used ===" ))) in let loop = [ Script.rawf ": list_iter ; for %s in $(cat %s) ; do\n{\n%s\n}\ndone" file_var list_file - (Format.asprintf "%a" Script.pp_posix convert_script) ] - in + (Format.asprintf "%a" Script.pp_posix convert_script) ] in unit (l_script.commands @ loop) | Int_bin_op (ia, op, ib) -> let open Script in @@ -666,9 +634,8 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = | `Plus -> "+" | `Mod -> "%" ) (to_argument ~arithmetic:true b_script.result) - (to_path_argument tmp.result) - in - a_script.commands @ b_script.commands @ [compute] ) + (to_path_argument tmp.result) in + a_script.commands @ b_script.commands @ [compute]) | Int_bin_comparison (ia, op, ib) -> let open Script in let a_script = continue ia in @@ -687,9 +654,8 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = | `Lt -> "-lt" | `Ne -> "-ne" ) (to_argument b_script.result) - (to_path_argument tmp.result) - in - a_script.commands @ b_script.commands @ [compute] ) + (to_path_argument tmp.result) in + a_script.commands @ b_script.commands @ [compute]) | Feed (string, u) -> let open Script in let string_script = continue string in @@ -712,7 +678,7 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = string_script.commands @ [ rawf "eval 'printf \"%%s\" \"$'%s'\"' > %s" (to_argument ~arithmetic:false string_script.result) - (to_path_argument tmp.result) ] ) + (to_path_argument tmp.result) ]) | Setenv (variable, value) -> let open Script in let var_script = continue variable in @@ -722,8 +688,7 @@ let rec to_ir : type a. fail_commands:_ -> tmpdb:_ -> a t -> Script.t = let cmd = rawf "eval 'export '%s'=\"$(cat %s)\"'" (to_argument ~arithmetic:false var_script.result) - (to_path_argument val_as_file.result) - in + (to_path_argument val_as_file.result) in make ( var_script.commands @ val_script.commands @ val_as_file.commands @ [cmd] ) @@ -765,12 +730,11 @@ let compile ?(default_tmpdir = `Fresh) ?(signal_name = "USR1") | `None -> rawf ": No TRAP" | `Exit_with v -> rawf "trap 'cat %s >&2 ; %s ; exit %d' %s" tmparg delete_fname v - signal_name ) ] - in + signal_name ) ] in let fail_commands s = match trap with | `Exit_with _ -> - [ rawf "printf '%%s\\n' %s > %s " (Filename.quote s) tmparg + [ rawf "printf '%%s\\n' %s > %s " (Caml.Filename.quote s) tmparg ; rawf "kill -s %s ${%s}" signal_name pid ] | `None -> failwith "You cannot use the `fail` construct with no `trap` strategy" @@ -780,8 +744,7 @@ let compile ?(default_tmpdir = `Fresh) ?(signal_name = "USR1") let make_tmp_vars = Tmp_db.tmp_vars tmpdb |> List.concat_map ~f:(fun (v, dir, cmd) -> - [cmtf "Making file %s" v; Make_directory dir; rawf "%s" cmd] ) - in + [cmtf "Making file %s" v; Make_directory dir; rawf "%s" cmd]) in let last_call = rawf "ret=$?\n%s\nexit $ret\n" delete_fname in make ( [delete_tmps] @ make_tmp_vars @ tmp.commands @ before @ s.commands @@ -857,12 +820,11 @@ let test () = ; Elist.( iter (make - [ int 1 - ; int 2 + [ int 1; int 2 ; Integer.(int 1 + int 2) ; Integer.(int 1 + int 1 + of_string (c_string "2")) ]) ~f:(fun item -> - printf (c_string "> %d\\n") [Integer.to_string (item ())] )) + printf (c_string "> %d\\n") [Integer.to_string (item ())])) ; if_then_else Integer.( int 1 + int 1 + of_string (c_string "2") @@ -883,7 +845,8 @@ let test () = ] ; seq [ setenv - (C_string.concat_list [c_string "A"; c_string "A"; c_string "A"]) + ~var: + (C_string.concat_list [c_string "A"; c_string "A"; c_string "A"]) (get_stdout (exec ["echo"; "HELLO WORLD"]) |> Byte_array.to_c) ; "Calling a sub-shell with `sh`,\nit should display HELLO WORLD" %%% exec ["sh"; "-c"; "echo \"$AAA\""] ] @@ -896,18 +859,17 @@ let test () = let v1 = c_string "V1" in let v2 = c_string "V2" in seq - [ setenv var v1 + [ setenv ~var v1 ; loop_seq_while C_string.(getenv var =$= v1) - [printf (c_string "Iteration\\n") []; setenv var v2] ]) ] - in + [printf (c_string "Iteration\\n") []; setenv ~var v2] ]) ] in List.iteri exprs ~f:(fun idx expr -> let ir = compile expr in fprintf std_formatter "==== TEST %d ====\n%a\n%!" idx Script.pp_posix ir ; - let script_file = sprintf "/tmp/script-%d.sh" idx in - let o = open_out script_file in + let script_file = Fmt.str "/tmp/script-%d.sh" idx in + let o = Caml.open_out script_file in fprintf (formatter_of_out_channel o) "\n%a\n%!" Script.pp_posix ir ; - flush o ; - close_out o ; - let res = ksprintf Sys.command "sh %s" script_file in - fprintf std_formatter "\nRESULT: %d\n" res ) + Caml.flush o ; + Caml.close_out o ; + let res = Fmt.kstr Caml.Sys.command "sh %s" script_file in + fprintf std_formatter "\nRESULT: %d\n" res) diff --git a/src/lib/transform.ml b/src/lib/transform.ml index 7ab0747..b3eb285 100644 --- a/src/lib/transform.ml +++ b/src/lib/transform.ml @@ -117,8 +117,7 @@ module Visitor = struct = fun (l, f) -> let newf (* : type a. (unit -> a t) -> unit t *) item = - self#expression (f item) - in + self#expression (f item) in List_iter (self#expression l, newf) method byte_array_to_c_string : byte_array t -> c_string t = @@ -148,7 +147,7 @@ module Visitor = struct method expression : type a. a Language.t -> a Language.t = fun e -> Option.iter trace ~f:(fun formatter -> - Format.fprintf formatter "-> %a\n" pp e ) ; + Format.fprintf formatter "-> %a\n" pp e) ; match e with | Exec l -> self#exec (List.map l ~f:self#expression) | Raw_cmd (x, y) -> self#raw_cmd (x, y) @@ -199,13 +198,13 @@ The `propagator` class inherits from `Visitor.nothing_doer` and overwrites only *) class propagator ?trace () = object (self) - inherit Visitor.nothing_doer ?trace () as super + inherit Visitor.nothing_doer ?trace () as _super (*md Boolean operators are not commutative, the left side has to be evaluated first and may break the execution flow (e.g. with `fail`). *) - method bool_operator (a, op, b) = + method! bool_operator (a, op, b) = let ga = self#expression a in let gb = self#expression b in match (ga, op, gb) with @@ -219,18 +218,18 @@ literals (all non-literals can be non-deterministic and side-effectful). *) - method string_operator (a, op, b) = + method! string_operator (a, op, b) = let ga = self#expression a in let gb = self#expression b in match (ga, op, gb) with | Literal (Literal.String sa), op, Literal (Literal.String sb) -> Literal ( match op with - | `Neq -> Literal.Bool (sa <> sb) - | `Eq -> Literal.Bool (sa = sb) ) + | `Neq -> Literal.Bool String.(sa <> sb) + | `Eq -> Literal.Bool String.(sa = sb) ) | _ -> String_operator (ga, op, gb) - method returns : type a. expr:a t -> _ = + method! returns : type a. expr:a t -> _ = fun ~expr ~value -> let e = self#expression expr in match (e, value) with @@ -238,7 +237,7 @@ side-effectful). | No_op, _ -> Construct.bool false | _ -> Returns {expr; value} - method if_ (c, t, e) = + method! if_ (c, t, e) = let gc = self#expression c in let gt = self#expression t in let ge = self#expression e in @@ -247,28 +246,28 @@ side-effectful). | Literal (Literal.Bool false) -> ge | _ -> If (gc, gt, ge) - method while_ ~condition ~body = + method! while_ ~condition ~body = match self#expression condition with | Literal (Literal.Bool false) -> No_op | cond -> While {condition= cond; body= self#expression body} - method not b = + method! not b = let gb = self#expression b in match gb with | Literal (Literal.Bool b) -> Literal (Literal.Bool (not b)) | other -> Not other - method seq l = + method! seq l = let transformed = - List.map ~f:self#expression l |> List.filter ~f:(( <> ) No_op) + List.map ~f:self#expression l |> List.filter ~f:Poly.(( <> ) No_op) in match transformed with [] -> No_op | [one] -> one | l -> Seq l - method pipe l = + method! pipe l = let tr = List.map ~f:self#expression l in match tr with Pipe l :: more -> Pipe (l @ more) | other -> Pipe other - method c_string_concat l = + method! c_string_concat l = let gl = self#expression l in match gl with | List [] -> Construct.c_string "" @@ -286,15 +285,14 @@ side-effectful). Byte_array_to_c_string (Literal (Literal.String (pstring ^ sitem))) :: more - | _, _ -> item :: prev ) - |> List.rev - in + | _, _ -> item :: prev) + |> List.rev in match build with | [one] -> one | more -> C_string_concat (List more) ) | default -> C_string_concat default - method byte_array_concat l = + method! byte_array_concat l = let gl = self#expression l in match gl with | List [] -> Construct.byte_array "" @@ -307,15 +305,14 @@ side-effectful). | ( Literal (Literal.String pstring) :: more , Literal (Literal.String sitem) ) -> Literal (Literal.String (pstring ^ sitem)) :: more - | _, _ -> item :: prev ) - |> List.rev - in + | _, _ -> item :: prev) + |> List.rev in match build with | [one] -> one | more -> Byte_array_concat (List more) ) | default -> Byte_array_concat default - method list_append (a, b) = + method! list_append (a, b) = let la = self#expression a in let lb = self#expression b in match (la, lb) with @@ -324,11 +321,11 @@ side-effectful). | List lla, List llb -> List (lla @ llb) | _, _ -> List_append (la, lb) - method list_iter (l, f) = + method! list_iter (l, f) = let gl = self#expression l in match gl with List [] -> No_op | _ -> List_iter (gl, f) - method int_bin_op (a, op, b) = + method! int_bin_op (a, op, b) = let ga = self#expression a in let gb = self#expression b in let default = Int_bin_op (ga, op, gb) in @@ -347,7 +344,7 @@ side-effectful). | _ -> default ) | _ -> default - method int_bin_comparison (a, op, b) = + method! int_bin_comparison (a, op, b) = let ga = self#expression a in let gb = self#expression b in let default = Int_bin_comparison (ga, op, gb) in @@ -377,13 +374,12 @@ side-effectful). let count = ref 0 in let check ?trace name e res = let p = process ?trace e in - incr count ; - match p = res with + Caml.incr count ; + match Poly.(p = res) with | true -> () | false -> failures := - (!count, name, Forget e, Forget res, Forget p) :: !failures - in + (!count, name, Forget e, Forget res, Forget p) :: !failures in check "no-op" No_op No_op ; check "some bool" Construct.(bool true &&& bool false) @@ -412,17 +408,11 @@ side-effectful). Construct.(C_string.concat_list [string "one"; string "-"; string "two"]) Construct.(string "one-two") ; let s n = - Construct.(get_stdout (exec [Int.to_string n]) |> Byte_array.to_c) - in + Construct.(get_stdout (exec [Int.to_string n]) |> Byte_array.to_c) in check "concat one-two" Construct.( C_string.concat_list - [ string "before" - ; s 0 - ; string "one" - ; string "-" - ; string "two" - ; s 1 + [ string "before"; s 0; string "one"; string "-"; string "two"; s 1 ; string "" ]) Construct.( C_string.concat_list [string "before"; s 0; string "one-two"; s 1]) ; @@ -438,9 +428,9 @@ side-effectful). [ e 42 ; loop_seq_while ("Comment on the success" %%% succeeds (s 0)) - [e 1; "Comment on the `setenv`" %%% setenv (string "bouh") expr] - ]) - in + [ e 1 + ; "Comment on the `setenv`" %%% setenv ~var:(string "bouh") expr + ] ]) in check "deep1" Construct.(make_deep Integer.(to_string (int 1 + int 0))) Construct.(make_deep Integer.(to_string (int 1))) ; @@ -462,9 +452,9 @@ side-effectful). Result:\n\ %a\n\ %!" - nth name pp e pp res pp p ) ; + nth name pp e pp res pp p) ; let nb = List.length more in - ksprintf failwith "There %s %d test failure%s" + Fmt.failwith "There %s %d test failure%s" (if nb > 1 then "were" else "was") nb (if nb > 1 then "s" else "") diff --git a/src/test-lib/dune b/src/test-lib/dune new file mode 100644 index 0000000..8617370 --- /dev/null +++ b/src/test-lib/dune @@ -0,0 +1 @@ +(library (name tests) (libraries genspio uri nonstd sosa) ) diff --git a/src/test-lib/test_lib.ml b/src/test-lib/test_lib.ml index bee7cda..ab5127c 100644 --- a/src/test-lib/test_lib.ml +++ b/src/test-lib/test_lib.ml @@ -26,7 +26,6 @@ module Shell = struct ; get_version: string } let make_shell name ~command ~get_version = {name; command; get_version} - let to_string t = t.name let known_shells () = @@ -35,17 +34,14 @@ module Shell = struct let dash_like bin ~get_version = make_shell (Filename.basename bin) ~command:(fun s args -> [bin; "-x"; s] @ args) - ~get_version - in + ~get_version in let busybox = make_shell "busybox" ~command:(fun s args -> ["busybox"; "ash"; "-x"; s] @ args) - ~get_version:"busybox | head -n 1" - in + ~get_version:"busybox | head -n 1" in let package_version package = (* for when there is no `--version`, `-V`, etc. we go the “debian” way *) - sprintf "dpkg -s %s | grep ^Version" package - in + sprintf "dpkg -s %s | grep ^Version" package in [ dash_like "dash" ~get_version:(package_version "dash") ; dash_like "bash" ~get_version:"bash --version | head -n 1" ; dash_like "sh" ~get_version:(package_version "sh") @@ -66,8 +62,7 @@ module Shell_directory = struct let name t = let opti = List.map t.optimization_passes ~f:(function `Cst_prop -> "-cp") - |> String.concat ~sep:"" - in + |> String.concat ~sep:"" in sprintf "%s-%s%s" (Shell.to_string t.shell) ( match t.compilation with | `Std_multi_line -> "StdML" @@ -82,8 +77,7 @@ module Shell_directory = struct (let long = String.map name ~f:(function | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9') as c -> c - | _ -> '_' ) - in + | _ -> '_') in if String.length long > 30 then String.sub_exn long ~index:0 ~length:30 else long) @@ -111,27 +105,24 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = "script" // sprintf "%s-opti-display.scm" (unique_name test) let success_path test = sprintf "_success/%s.txt" @@ unique_name test - let failure_path test = sprintf "_failure/%s.txt" @@ unique_name test - let stdout_path test = sprintf "_log/%s/stdout.txt" @@ unique_name test - let stderr_path test = sprintf "_log/%s/stderr.txt" @@ unique_name test - let display_script t = function - | Exits {no_trap; name; args; returns; script} -> - Genspio.Compile.to_string_hum script + let display_script _t = function + | Exits {script; _} -> Genspio.Compile.to_string_hum script let display_opti_script t = function - | Exits {no_trap; name; args; returns; script} -> - List.fold t.optimization_passes ~init:script ~f:(fun prev -> function - | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev ) + | Exits {script; _} -> + List.fold t.optimization_passes ~init:script ~f:(fun prev -> + function + | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev) |> Genspio.Compile.to_string_hum let run_test_script t = let test_name = name t in function - | Exits {no_trap; name; args; returns; script} as test -> + | Exits {name; args; returns; _} as test -> let fill_result_file which = let echos = [ sprintf "- Returns $RRR (expected: %d)." returns @@ -141,8 +132,7 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = (script_opti_display test) ; sprintf "- Test-runner: \\`%s\\`" (run_test_path test) ; sprintf "- STDOUT: \\`%s\\`" (stdout_path test) - ; sprintf "- STDERR: \\`%s\\`" (stderr_path test) ] - in + ; sprintf "- STDERR: \\`%s\\`" (stderr_path test) ] in let file, first_line = match which with | `OK -> @@ -150,15 +140,12 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = , sprintf "- **OK**: \\`%s\\`" (unique_name test) ) | `KO -> ( failure_path test - , sprintf "- **KO**: \\`%s\\`" (unique_name test) ) - in + , sprintf "- **KO**: \\`%s\\`" (unique_name test) ) in let lines = sprintf "printf -- \"%s\\n\" > %s" first_line file :: List.map echos ~f:(fun l -> - sprintf "printf -- \" %s\\n\" >> %s" l file ) - in - String.concat ~sep:"\n" lines - in + sprintf "printf -- \" %s\\n\" >> %s" l file) in + String.concat ~sep:"\n" lines in sprintf "mkdir -p _success _failure %s\n\ export TMPDIR=$PWD/_tmp/%s\n\ @@ -183,11 +170,11 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = else "" ) let script_content t = function - | Exits {no_trap; name; args; returns; script} -> ( + | Exits {no_trap; script; _} -> ( let script = - List.fold t.optimization_passes ~init:script ~f:(fun prev -> function - | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev - ) + List.fold t.optimization_passes ~init:script ~f:(fun prev -> + function + | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev) in match t.compilation with | `Std_one_liner -> Genspio.Compile.to_one_liner ~no_trap script @@ -198,7 +185,7 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = |> Format.asprintf "%a\n" Genspio.Compile.To_slow_flow.Script.pp_posix ) - let make_report_path t = "script" // "make_report.sh" + let make_report_path _ = "script" // "make_report.sh" let make_report_content t testlist = (let open Genspio.EDSL_v0 in @@ -208,8 +195,7 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = (exec ["ls"; "-1"; dir] ||> exec ["wc"; "-l"]) (exec ["echo"; "No-dir"]) ||> exec ["tr"; "-d"; "\\n"] - |> get_stdout |> Byte_array.to_c - in + |> get_stdout |> Byte_array.to_c in seq [ exec [ "printf" @@ -221,7 +207,7 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = | `Std_multi_line -> "Standard-multi-line" | `Slow_stack -> "Slow-stack" ) ( List.map t.optimization_passes ~f:(function `Cst_prop -> - "cst-prop" ) + "cst-prop") |> String.concat ~sep:"→" ) (List.length testlist) ] ; call @@ -246,13 +232,13 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = (make_report_path t) :: sprintf "check:\n\t@%s\n\n" ( List.map testlist ~f:(fun tst -> - sprintf "test -f '%s'" (success_path tst) ) + sprintf "test -f '%s'" (success_path tst)) |> String.concat ~sep:" \\\n && " ) :: List.map testlist ~f:(fun test -> sprintf "# Test %s with %s\n%s:\n\t%ssh %s" (unique_name test) (Shell.to_string t.shell) (success_path test) (if t.verbose then "" else "@") - (run_test_path test) ) + (run_test_path test)) |> String.concat ~sep:"\n" let scripts t testlist = @@ -260,7 +246,7 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = [ (script_path test, script_content t test) ; (run_test_path test, run_test_script t test) ; (script_display test, display_script t test) - ; (script_opti_display test, display_opti_script t test) ] ) + ; (script_opti_display test, display_opti_script t test) ]) let contents t ~path testlist = let test_path = path in @@ -271,7 +257,7 @@ let optimize : type a. _ -> a Genspio.Language.t -> _ = ; `File (test_path // make_report_path t, make_report_content t testlist) ] @ List.map (scripts t testlist) ~f:(fun (spath, content) -> - `File (sprintf "%s/%s" test_path spath, content) ) + `File (sprintf "%s/%s" test_path spath, content)) end module Test_directory = struct @@ -283,8 +269,7 @@ module Test_directory = struct let help t = let shell_names = List.map t.shell_tests ~f:Shell_directory.name in let code_list l = - List.map l ~f:(sprintf "`%s`") |> String.concat ~sep:", " - in + List.map l ~f:(sprintf "`%s`") |> String.concat ~sep:", " in sprintf "Genspio Tests Master Makefile\n\ =============================\n\n\ @@ -302,9 +287,8 @@ module Test_directory = struct let makefile t = let shell_reports = List.map t.shell_tests ~f:(fun sh -> - Shell_directory.name sh // "report.md" ) - |> String.concat ~sep:" " - in + Shell_directory.name sh // "report.md") + |> String.concat ~sep:" " in let shell_names = List.map t.shell_tests ~f:Shell_directory.name in let shell_run_targets = List.map shell_names ~f:(sprintf "run-%s") |> String.concat ~sep:" " @@ -318,7 +302,7 @@ module Test_directory = struct List.mem ~set:t.important_shells (sht.Shell_directory.shell |> Shell.to_string) then Some (sprintf "check-%s" (Shell_directory.name sht)) - else None ) + else None) |> String.concat ~sep:" " ) ; "report: report.md" ; sprintf "report.md: %s\n\tcat %s > report.md" shell_reports shell_reports @@ -331,7 +315,7 @@ module Test_directory = struct let dir = Shell_directory.name shtest in [ sprintf "%s/report.md:\n\t@ ( cd %s ; $(MAKE) report ; )" dir dir ; sprintf "run-%s:\n\t@ ( cd %s ; $(MAKE) ; )" dir dir - ; sprintf "check-%s:\n\t@ ( cd %s ; $(MAKE) check ; )" dir dir ] ) + ; sprintf "check-%s:\n\t@ ( cd %s ; $(MAKE) check ; )" dir dir ]) |> String.concat ~sep:"\n" let contents t ~path testlist = @@ -342,7 +326,7 @@ module Test_directory = struct (* let comp = Shell_directory.{ shell; verbose = t.verbose } in *) Shell_directory.contents shtest ~path:(path // Shell_directory.name shtest) - testlist ) + testlist) end module Example = struct @@ -369,20 +353,18 @@ module Example = struct let fence = String.make 50 '`' in ff fmt "%s%s@\n%s@\n%s@\n@\n" fence lang (String.strip code) fence in - let if_show s f = if List.mem s show then f () else () in + let if_show s f = if List.mem s ~set:show then f () else () in let try_url = let base = - try Sys.getenv "genspio_demo_url" with _ -> default_demo_url - in - sprintf "%s?input=%s" base (Uri.pct_encode ocaml_code) - in + try Sys.getenv "genspio_demo_url" with _ -> default_demo_url in + sprintf "%s?input=%s" base (Uri.pct_encode ocaml_code) in ff fmt "@\n%s@\n%s@\n@\n%s@ [[Try-Online](%s)]@\n@\n" name (String.map name ~f:(fun _ -> '-')) description try_url ; md_code_block "ocaml" ocaml_code ; if_show `Pretty_printed (fun () -> ff fmt "Pretty-printed:@\n@\n" ; - md_code_block "scheme" (Genspio.Compile.to_string_hum code) ) ; + md_code_block "scheme" (Genspio.Compile.to_string_hum code)) ; ( match Genspio.Compile.To_posix.(string ~options:multi_line) code with | Ok script -> let tmp = Filename.temp_file "genspio-example" ".sh" in @@ -393,8 +375,7 @@ module Example = struct let out = Filename.temp_file "genspio-example" ".out" in let err = Filename.temp_file "genspio-example" ".err" in let result = - Sys.command (sprintf "bash %s > %s 2> %s" tmp out err) - in + Sys.command (sprintf "bash %s > %s 2> %s" tmp out err) in (* ff fmt " *@[ Std-OUT:@ `%s`@]@\n" out; *) (* ff fmt " *@[ Std-ERR:@ `%s`@]@\n" err; *) let show_file name path = @@ -405,14 +386,12 @@ module Example = struct try ff fmt "%c" @@ input_char i ; loop () - with _ -> () - in - loop () ; ff fmt "@\n%s@\n@\n" fence - in + with _ -> () in + loop () ; ff fmt "@\n%s@\n@\n" fence in if_show `Compiled (fun () -> ff fmt "Compiled to POSIX (%d bytes):@\n@\n" (String.length script) ; - md_code_block "shell" script ) ; + md_code_block "shell" script) ; ff fmt "@[Running@ *it*@ " ; ( match result with | 0 -> ff fmt "**succeeds**." diff --git a/src/test/dune b/src/test/dune new file mode 100644 index 0000000..abe8623 --- /dev/null +++ b/src/test/dune @@ -0,0 +1,2 @@ +(executable (name main) (libraries genspio tests nonstd sosa)) + diff --git a/src/test/main.ml b/src/test/main.ml index 5f52bb4..93736ef 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -5,13 +5,9 @@ module Compile = Genspio.Language module Construct = Genspio.EDSL_v0 let exits = Test.exits - let shexit n = Construct.exec ["exit"; Int.to_string n] - let return n = Construct.exec ["sh"; "-c"; sprintf "exit %d" n] - let tprintf fmt = ksprintf (fun s -> Construct.exec ["printf"; "%s"; s]) fmt - let comment fmt = ksprintf (fun s -> Construct.exec [":"; s]) fmt let assert_or_fail name cond = @@ -20,7 +16,6 @@ let assert_or_fail name cond = (seq [tprintf "Fail: %s\n" name; fail name]) let tests = ref [] - let add_tests t = tests := t :: !tests let () = @@ -124,8 +119,7 @@ let () = let return_value_value = 31 in let will_be_escaped = "newline:\n tab: \t \x42\b" in let will_not_be_escaped = - "spaces, a;c -- ' - '' \\ ''' # '''' @ ${nope} & ` ~" - in + "spaces, a;c -- ' - '' \\ ''' # '''' @ ${nope} & ` ~" in seq [ call [string "rm"; string "-f"; stdout; stderr; return_value_path] ; write_output ~stdout ~stderr ~return_value:return_value_path @@ -214,8 +208,7 @@ let () = (let open Construct in let tmp = "/tmp/test_loop_while" in let cat_potentially_empty = - if_then_else (exec ["cat"; tmp] |> succeeds) nop (tprintf "") - in + if_then_else (exec ["cat"; tmp] |> succeeds) nop (tprintf "") in seq [ exec ["rm"; "-f"; tmp] ; exec ["rm"; "-f"; tmp] @@ -245,8 +238,7 @@ let () = string ~doc:"String one" ["-f"] & string ~doc:"String two" ["-g"] & flag ~doc:"Bool one" ["-v"] - & usage "Usage string\nwith bunch of lines to\nexplain stuff" - in + & usage "Usage string\nwith bunch of lines to\nexplain stuff" in parse spec (fun ~anon one two bone -> seq [ printf @@ -268,8 +260,7 @@ let () = C_string.(string single =$= string "--") (let concated_in_ocaml = String.concat ~sep:"" - [anon1; "-g"; minus_g; anon2; anon3] - in + [anon1; "-g"; minus_g; anon2; anon3] in [ printf (ksprintf string "######### In dash-dash case: #########\\n=== \ @@ -277,12 +268,11 @@ let () = '%%s'\\n=== concat_elist anon: '%%s'\\n=== \ string.concat: '%%s'\\n" (String.length concated_in_ocaml)) - [ Bool.to_string bone - ; string anon3 - ; C_string.concat_elist anon - ; string concated_in_ocaml ] + [ Bool.to_string bone; string anon3 + ; C_string.concat_elist anon; string concated_in_ocaml + ] ; Elist.iter anon ~f:(fun v -> - printf (string "=== anonth: %s\\n") [v ()] ) + printf (string "=== anonth: %s\\n") [v ()]) ; assert_or_fail "dash-dash" ( (not bone) &&& C_string.( @@ -307,15 +297,12 @@ let () = (* Should be always true *) (return 12) (* i.e. we're testing that weird characters have good escaping *) - (return 44)) ] )) - in + (return 44)) ])) in List.mapi ~f:(fun i f -> f i) - [ make 11 minus_f "" - ; make 12 "not-one" "" + [ make 11 minus_f ""; make 12 "not-one" "" ; make 12 "not-one" "" ~anon3:(String.make 20 'S') - ; make 11 "not-one" "-v" - ; make 12 minus_f "--" + ; make 11 "not-one" "-v"; make 12 minus_f "--" ; (* the `--` should prevent the `-g one` from being parsed *) make 12 minus_f "--" ~anon3:(String.make 6 'S') ; make 12 minus_f "--" ~anon3:(String.make 7 'S') @@ -325,17 +312,14 @@ let () = ; make 12 minus_f "--" ~anon3:(String.make 11 'S') ; make 12 minus_f "--" ~anon3:(String.make 12 'S') ; make 12 minus_f "--" ~anon3:(String.make 20 'S') - ; make 12 "not-one" "-x" - ; (* option does not exist (untreated for now) *) - make 12 "not-one" "--v" - ; make 12 "not-one" "-v j" + ; make 12 "not-one" "-x"; (* option does not exist (untreated for now) *) + make 12 "not-one" "--v"; make 12 "not-one" "-v j" ; make 11 "not \\ di $bouh one" "-v" ; make 12 "not \\ di $bouh one" " -- -v" ; make 12 "one \nwith spaces and \ttabs -dashes -- " "" ; make 12 "one \nwith spaces and \ttabs -dashes -- " "" ; make 12 "one with \\ spaces and \ttabs -dashes -- " "" - ; make 0 "not-one" "--help" - ; make 0 "not-one" "-help" + ; make 0 "not-one" "--help"; make 0 "not-one" "-help" ; make 0 "not-one" "-h" ] |> List.concat @@ -350,19 +334,17 @@ let () = (* let tmp = tmp_file "single-is-anon" in *) get_stdout (Elist.iter anon ~f:(fun item -> - printf (string "^^^%s@@@") [item ()] )) + printf (string "^^^%s@@@") [item ()])) (* |> Byte_array.to_c *) =$= ( List.map ~f:(sprintf "^^^%s@@@") anons_expected - |> String.concat ~sep:"" |> str )) - in + |> String.concat ~sep:"" |> str )) in let spec = let open Command_line in let open Arg in string ~doc:"String one" ["-f"] & string ~doc:"String two" ["-g"] & flag ~doc:"Bool one" ["-v"] - & usage "Usage string\nwith bunch of lines to\nexplain stuff" - in + & usage "Usage string\nwith bunch of lines to\nexplain stuff" in let make ?(anon3 = "BBBBBBB") ret minus_g single count = let anon1 = "annonlkjde" in let anon2 = "annon 02e930 99e3\n d \t eij" in @@ -387,8 +369,7 @@ let () = Str.(string single =$= string "--") (let concated_in_ocaml = String.concat ~sep:"" - [anon1; "-g"; minus_g; anon2; anon3] - in + [anon1; "-g"; minus_g; anon2; anon3] in [ printf (ksprintf string "######### In dash-dash case: #########\\n=== \ @@ -396,12 +377,10 @@ let () = '%%s'\\n=== concat_elist anon: '%%s'\\n=== \ string.concat: '%%s'\\n" (String.length concated_in_ocaml)) - [ Bool.to_string bone - ; string anon3 - ; Str.concat_elist anon - ; string concated_in_ocaml ] + [ Bool.to_string bone; string anon3 + ; Str.concat_elist anon; string concated_in_ocaml ] ; Elist.iter anon ~f:(fun v -> - printf (string "=== anonth: %s\\n") [v ()] ) + printf (string "=== anonth: %s\\n") [v ()]) ; assert_or_fail "dash-dash" ( (not bone) &&& check_anon anon @@ -418,27 +397,23 @@ let () = (* Should be always true *) (return 12) (* i.e. we're testing that weird characters have good escaping *) - (return 44)) ] )) - in + (return 44)) ])) in let only_anon args name = exits ~name:(sprintf "parse-cli-only-anon-%s" name) ~args 0 - (Command_line.parse spec (fun ~anon one two bone -> + (Command_line.parse spec (fun ~anon _ _ _ -> assert_or_fail (sprintf "anon-is-anon-%s" name) - (check_anon anon args) )) - in + (check_anon anon args))) in [ only_anon [] "nothing" ; only_anon ["one"] "one" ; only_anon (List.init 4 ~f:(sprintf "a%d")) "fouras" ] @ List.mapi ~f:(fun i f -> f i) - [ make 11 minus_f "" - ; make 12 "not-one" "" + [ make 11 minus_f ""; make 12 "not-one" "" ; make 12 "not-one" "" ~anon3:(String.make 20 'S') - ; make 11 "not-one" "-v" - ; make 12 minus_f "--" + ; make 11 "not-one" "-v"; make 12 minus_f "--" ; (* the `--` should prevent the `-g one` from being parsed *) make 12 minus_f "--" ~anon3:(String.make 6 'S') ; make 12 minus_f "--" ~anon3:(String.make 7 'S') @@ -448,17 +423,14 @@ let () = ; make 12 minus_f "--" ~anon3:(String.make 11 'S') ; make 12 minus_f "--" ~anon3:(String.make 12 'S') ; make 12 minus_f "--" ~anon3:(String.make 20 'S') - ; make 12 "not-one" "-x" - ; (* option does not exist (untreated for now) *) - make 12 "not-one" "--v" - ; make 12 "not-one" "-v j" + ; make 12 "not-one" "-x"; (* option does not exist (untreated for now) *) + make 12 "not-one" "--v"; make 12 "not-one" "-v j" ; make 11 "not \\ di $bouh one" "-v" ; make 12 "not \\ di $bouh one" " -- -v" ; make 12 "one \nwith spaces and \ttabs -dashes -- " "" ; make 12 "one \nwith spaces and \ttabs -dashes -- " "" ; make 12 "one with \\ spaces and \ttabs -dashes -- " "" - ; make 0 "not-one" "--help" - ; make 0 "not-one" "-help" + ; make 0 "not-one" "--help"; make 0 "not-one" "-help" ; make 0 "not-one" "-h" ] |> List.concat @@ -489,8 +461,7 @@ let () = seq [ byte_array "dj ijdedej j42 ijde - '' " >> seq - [ tprintf "Going to die\n" - ; fail "cannot poison death" + [ tprintf "Going to die\n"; fail "cannot poison death" ; return 42 ] ; return 23 ]) ; () @@ -504,14 +475,12 @@ let () = let name = sprintf "%s %s %d" cmd (if yn = gives then "returns" else "does not return") - value - in + value in exits ~name yn Construct.( if_then_else (exec ["sh"; "-c"; cmd] |> returns ~value) - (return gives) (return does_not_give)) - in + (return gives) (return does_not_give)) in List.concat [ t "ls" gives 0 ; t "ls /deijdsljidisjeidje" does_not_give 0 @@ -567,8 +536,7 @@ let () = let cat_tmp = exec ["cat"; tmp] in let succeed_or_die ut = if_then_else (succeeds ut) nop - (seq [tprintf "Failure !"; fail "succeed_or_die"]) - in + (seq [tprintf "Failure !"; fail "succeed_or_die"]) in seq [ exec ["rm"; "-f"; tmp] ; tprintf "ps-output:\\n" @@ -692,8 +660,7 @@ let () = (* We cannot use OCaml's Sys.getenv because the compilation output may be run on a different host/system (through SSH or alike). *) exec ["sh"; "-c"; sprintf "echo ${%s} | tr -d '\\n'" v] - |> get_stdout |> Byte_array.to_c - in + |> get_stdout |> Byte_array.to_c in if_then_else C_string.( getenv (string "HOME") @@ -743,8 +710,7 @@ let () = let var = string "VVVVVVV" in let assert_or_return ret cond = if_then_else cond nop - (seq [tprintf "Fail: %d" ret; fail "assert_or_return"]) - in + (seq [tprintf "Fail: %d" ret; fail "assert_or_return"]) in let set_and_test ?(varname = "XXXX") value = let var = string varname in seq @@ -767,16 +733,12 @@ let () = [ getenv var ; exec ["sh"; "-c"; sprintf "echo \"ECHO: $%s\"" varname] |> get_stdout |> Byte_array.to_c ] - ; ksprintf fail "fail: %s" value ] ] - in + ; ksprintf fail "fail: %s" value ] ] in seq [ assert_or_return 27 C_string.(getenv var =$= string "") - ; set_and_test "bouh" - ; set_and_test "bouh\nbah" - ; set_and_test "bouh\nbah\n" - ; set_and_test "bouh'bah" - ; set_and_test "bouh\"bah" - ; set_and_test "bouh\001bah" + ; set_and_test "bouh"; set_and_test "bouh\nbah" + ; set_and_test "bouh\nbah\n"; set_and_test "bouh'bah" + ; set_and_test "bouh\"bah"; set_and_test "bouh\001bah" ; (* We check that the environment is affected properly: *) setenv ~var:(string "AAA") (string "aaa") ; assert_or_return 42 @@ -807,20 +769,20 @@ let () = let () = add_tests @@ List.concat - [ exits 2 ~name:"no-trap" Genspio.EDSL.(return 2) - (* Dying with error messages does not work without `trap` any more + [ exits 2 ~name:"no-trap" (return 2) + (* Dying with error messages does not work without `trap` any more (string-schism): *) - (* exits 2 ~no_trap:true ~name:"no-trap-but-failwith" Genspio.EDSL.( *) - (* seq [ *) - (* with_failwith (fun die -> *) - (* seq [ *) - (* (\* tprintf "Dying now\n"; *\) *) - (* die *) - (* ~message:(byte_array "HElllooo I'm dying!!\n") ~return:(int 2) *) - (* ] *) - (* ); *) - (* ] *) - (* ); *) + (* exits 2 ~no_trap:true ~name:"no-trap-but-failwith" Genspio.EDSL.( *) + (* seq [ *) + (* with_failwith (fun die -> *) + (* seq [ *) + (* (\* tprintf "Dying now\n"; *\) *) + (* die *) + (* ~message:(byte_array "HElllooo I'm dying!!\n") ~return:(int 2) *) + (* ] *) + (* ); *) + (* ] *) + (* ); *) ] let () = @@ -840,12 +802,9 @@ let () = let recognizable = "heelllloooooo" in seq [ call - [ string "printf" - ; string "1: %s, 2: %s\n" - ; tmp1#path + [ string "printf"; string "1: %s, 2: %s\n"; tmp1#path ; tmp2#path ] - ; tmp1#set init - ; tmp2#set init + ; tmp1#set init; tmp2#set init ; write_output ~stdout:tmp1#path ~stderr:tmp2#path (with_redirections (exec ["printf"; "%s"; recognizable]) @@ -871,8 +830,7 @@ let () = (exec ["printf"; "%s"; recognizable]) [ to_file (int 3) tmp1#path ; to_file (int 3) tmp2#path - ; (* we hijack tmp1's use of fd 3 *) - to_fd (int 2) (int 3) + ; (* we hijack tmp1's use of fd 3 *) to_fd (int 2) (int 3) ; to_fd (int 1) (int 2) ] ; call [string "cat"; tmp1#path] ; call [string "cat"; tmp2#path] @@ -892,8 +850,7 @@ let () = exec ["ps"] |> get_stdout >> exec ["grep"; "bash"] - |> returns ~value:0 - in + |> returns ~value:0 in seq [ tmp1#set (byte_array "") ; write_output ~return_value:tmp2#path @@ -990,8 +947,7 @@ let () = assert_or_fail name C_string.( concat_elist (Elist.append (slist la) (slist lb)) - =$= string (la @ lb |> String.concat ~sep:"")) - in + =$= string (la @ lb |> String.concat ~sep:"")) in seq [ make_string_concat_test "test1" ["one"; "two"; "three"] [] ; make_string_concat_test "test2" ["one"; "two"; "three"] ["four"] @@ -1037,26 +993,19 @@ let () = ( C_string.concat_list [tmp#get_c; string ":"; v () |> Byte_array.to_c] |> C_string.to_bytes ) - (* The `:` makes sure we count right [""] ≠ [""; ""] etc. *) - ] ) + (* The `:` makes sure we count right [""] ≠ [""; ""] etc. *) + ]) ; assert_or_fail name C_string.( tmp#get_c =$= string (String.concat (List.map l ~f:(sprintf ":%s")) ~sep:"")) - ; return 5 ]) - in + ; return 5 ]) in List.concat_mapi ~f:make_list_iter_strings_test - [ ["zero"] - ; ["one"; "two"; "three"] - ; ["four"] - ; [] - ; [""] - ; [""; ""] - ; [""; "bouh"; ""; "bah"] - ; ["deiajd\ndedaeijl"; ""] + [ ["zero"]; ["one"; "two"; "three"]; ["four"]; []; [""]; [""; ""] + ; [""; "bouh"; ""; "bah"]; ["deiajd\ndedaeijl"; ""] ; ["deiajd\ndeda\001eijl"; ":"] - (* Used `\001` because we convert to C-strings in the *) + (* Used `\001` because we convert to C-strings in the *) ] let () = @@ -1065,8 +1014,7 @@ let () = let make_int_test i l = let name = sprintf "list-iter-ints-%d-%s" i - (List.map l ~f:Int.to_string |> String.concat ~sep:"-") - in + (List.map l ~f:Int.to_string |> String.concat ~sep:"-") in exits 5 ~name (let open Genspio.EDSL_v0 in let ilist = List.map l ~f:int |> Elist.make in @@ -1089,8 +1037,7 @@ let () = Integer.(v () = v ()) ; tmp#set Integer.( - (tmp#get |> of_byte_array) + v () |> to_byte_array) ] - ) + (tmp#get |> of_byte_array) + v () |> to_byte_array) ]) ; printf (string "TMP: %s, TMP2: %s\\n") [tmp#path; tmp2#path] ; call [string "cat"; tmp#path] ; printf (string "::\\n") [] @@ -1098,10 +1045,9 @@ let () = C_string.( tmp#get_c =$= Integer.to_string (List.fold ~init:0 l ~f:( + ) |> int)) - ; return 5 ]) - in + ; return 5 ]) in List.concat_mapi ~f:make_int_test - [[]; [1]; [3]; [1; 2; 3]; [1; 2; 3; 0]; List.init 42 (fun i -> i)] + [[]; [1]; [3]; [1; 2; 3]; [1; 2; 3; 0]; List.init 42 ~f:(fun i -> i)] let () = add_tests @@ -1115,14 +1061,12 @@ let () = ; exec ["sed"; "s/wo/Wo/"] ; exec ["sed"; "s/h/H/"] ; exec ["tr"; "-d"; "\\n"] ] - |> get_stdout |> Byte_array.to_c - in + |> get_stdout |> Byte_array.to_c in let fed = "let fed" %%% ( bag |> C_string.to_bytes >> pipe [exec ["tr"; "H"; "B"]] - |> get_stdout |> Byte_array.to_c ) - in + |> get_stdout |> Byte_array.to_c ) in "pipe-basic test" %%% seq [ eprintf (string "Bag: %s") [bag] @@ -1158,7 +1102,7 @@ let () = ; tmp2#set (str "") ; cmd ||> on_stdin_lines (fun line -> - seq [tmp2#append line; tmp2#append (str "\n")] ) + seq [tmp2#append line; tmp2#append (str "\n")]) ; say "<<%s>> Vs <<%s>>" [tmp1#get; tmp2#get] ; assert_or_fail "tmp1 = tmp2" Str.(tmp1#get =$= tmp2#get) ; return 12 ]) @@ -1173,8 +1117,7 @@ let () = Genspio.EDSL.( let make_test f input output = assert_or_fail (sprintf "%S" output) - Str.(f (printf (str input) []) =$= str output) - in + Str.(f (printf (str input) []) =$= str output) in seq [ make_test get_stdout_one_line "one two\\nthree\\nfo ur" "one twothreefo ur" @@ -1229,13 +1172,11 @@ let () = (if does then "" else "not") pre extended_re) ( greps_to ~extended_re (str re) (printf (str pre) []) - |> if does then fun e -> e else not ) - in + |> if does then fun e -> e else not ) in let tn = tst false in let te = tst true in seq - [ tn "hello" "hello" true - ; te "hello" "hello" true + [ tn "hello" "hello" true; te "hello" "hello" true ; te "hello" "\\n ldje hello dleijsd\\n" true ; tn "helllo" "\\n ldje hello dleijsd\\n" false ; tn "hel\\*o" "\\n ldje hello dleijsd\\n" false @@ -1244,16 +1185,14 @@ let () = ; te "hel*o" "\\n ldje hello dleijsd\\n" true ; tn " hell?o " "\\n ldje hello dleijsd\\n" false ; te " hell?o " "\\n ldje hello dleijsd\\n" true - ; return 12 ]) ] - in + ; return 12 ]) ] in add_tests (List.concat tests) let compilation_error_tests () = let results = ref [] in let test ?options e expect = let res = Genspio.Compile.To_posix.string ?options e in - results := (e, expect res, res) :: !results - in + results := (e, expect res, res) :: !results in let open Genspio in test EDSL.( @@ -1277,8 +1216,7 @@ let compilation_error_tests () = true | _ -> false) ; let options = - {Genspio.Compile.To_posix.multi_line with fail_with= `Nothing} - in + {Genspio.Compile.To_posix.multi_line with fail_with= `Nothing} in test ~options EDSL.( "comment 0" %%% seq [exec ["echo"; "fail"]; "cmt2" %%% fail "failure"]) @@ -1295,12 +1233,12 @@ let compilation_error_tests () = let res_str = match res with | Ok s -> s - | Error e -> Genspio.Compile.To_posix.error_to_string e - in + | Error e -> Genspio.Compile.To_posix.error_to_string e in printf "* %s: %s\n%s\n%!%!" (if succ then "SUCCESS" else "FAILURE") - (String.sub expr_str 0 60 |> Option.value ~default:expr_str) - res_str ) ; + ( String.sub expr_str ~index:0 ~length:60 + |> Option.value ~default:expr_str ) + res_str) ; List.exists !results ~f:(fun (_, res, _) -> res = false) let () = @@ -1311,9 +1249,8 @@ let () = ksprintf (fun s -> eprintf "Error: %s\nUsage: %s\n%!" s usage ; - exit 1 ) - fmt - in + exit 1) + fmt in let anon_fun p = anon := p :: !anon in let no_compilation_tests = ref false in let extra_slow_flow_tests = ref false in @@ -1353,7 +1290,6 @@ let () = | moar -> failf "Too many arguments: %s" (String.concat ~sep:", " moar) in Option.iter path_opt ~f:(fun path -> - let open Test in let testlist = List.concat !tests |> @@ -1363,12 +1299,8 @@ let () = let matches name = String.index_of_string name ~sub:s <> None in fun tests -> List.filter tests ~f:(function - | Tests.Test_lib.Test.Exits - {no_trap; name; args; returns; script} - when matches name -> - true - | other -> false ) - in + | Tests.Test_lib.Test.Exits {name; _} when matches name -> true + | _ -> false) in printf "Testlist: %d\n%!" (List.length testlist) ; let testdir = let tests = @@ -1383,8 +1315,7 @@ let () = ; make `Std_multi_line [] ; make `Std_multi_line [`Cst_prop] ; make `Slow_stack [] - ; make `Slow_stack [`Cst_prop] ] ) - in + ; make `Slow_stack [`Cst_prop] ]) in let open Test_directory in {shell_tests= tests; important_shells= !important_shells; verbose= true} in @@ -1393,10 +1324,9 @@ let () = | `File (p, v) -> let mo = open_out p in fprintf mo "%s\n" v ; close_out mo - | `Directory v -> ksprintf Sys.command "mkdir -p '%s'" v |> ignore ) ) ; + | `Directory v -> ksprintf Sys.command "mkdir -p '%s'" v |> ignore)) ; let errors = - if !no_compilation_tests then false else compilation_error_tests () - in + if !no_compilation_tests then false else compilation_error_tests () in if !extra_slow_flow_tests then Genspio.To_slow_flow.test () ; if !extra_transform_cp_tests then Genspio.Transform.Constant_propagation.test () ; diff --git a/tools/build-doc.sh b/tools/build-doc.sh index a738045..cfeabd0 100644 --- a/tools/build-doc.sh +++ b/tools/build-doc.sh @@ -2,17 +2,22 @@ set -e -genspio_small_examples=_build/default/src/examples/small_examples.exe +genspio_small_examples_name=src/examples/small_examples.exe +genspio_small_examples=_build/default/$genspio_small_examples_name -ocaml please.mlt configure -jbuilder build @install -jbuilder build @doc -jbuilder build $genspio_small_examples +dune build @install +dune build @doc +dune build $genspio_small_examples_name export output_path=_build/doc/html/ rm -fr $output_path mkdir -p $output_path -cp -r _build/default/_doc/_html/* $output_path/ +odoc_result=_build/default/_doc/_html/ +cp -r $odoc_result/* $output_path/ || { + find _build/default/ | sed 's/^/ /' + echo "Copying '$odoc_result/' failed :(" + exit 2 + } css_file=ssc.css css_path=$output_path/$css_file diff --git a/tools/please_lib.ml b/tools/please_lib.ml deleted file mode 100644 index e6b9307..0000000 --- a/tools/please_lib.ml +++ /dev/null @@ -1,230 +0,0 @@ -(** - A not-really-library to create ["configure.ml"] (or ["please.ml"]) files. - - Add the file in your repo somewhere and [#use] it in your repo. - - {[ - #use "tools/please_lib.ml";; - ]} - - -*) - -module String = StringLabels -module List = ListLabels -open Printf - -let ( // ) = Filename.concat - -module Util = struct - let write_lines p l = - let o = open_out p in - List.iter l ~f:(fprintf o "%s\n") ; - close_out o - - let cmdf fmt = - ksprintf - (fun s -> - match Sys.command s with - | 0 -> () - | other -> ksprintf failwith "Command %S returned %d" s other ) - fmt -end - -module Merlin = struct - let lines ?(pkg = []) ?(s = []) () = - List.map s ~f:(sprintf "S %s") @ List.map pkg ~f:(sprintf "PKG %s") -end - -module Jbuilder = struct - let jbuild l = [";; Generated by `please_lib.ml`"; "(jbuild_version 1)"] @ l - - let executable ?(ppx = []) ?(modules = []) ?(single_module = false) - ~libraries name = - sprintf "(executable ((name %s) %s (libraries (%s))%s))" name - ( if ppx = [] then "" - else sprintf "(preprocess (pps (%s)))" (String.concat ~sep:" " ppx) ) - (String.concat libraries ~sep:" ") - ( match (single_module, modules) with - | true, [] -> sprintf "(modules (%s))" name - | true, _ -> - failwith "Cannot call `executable` with ~single_module and ~modules" - | false, [] -> "" - | false, more -> sprintf "(modules (%s))" (String.concat " " more) ) - - let rule ~targets ?(deps = []) actions = - sprintf "(rule ((targets (%s))(deps (%s))(action (progn\n%s))))" - (String.concat ~sep:" " targets) - (String.concat ~sep:" " deps) - (String.concat ~sep:"\n" actions) - - let with_stdout_to path l = - sprintf "(with-stdout-to %S (progn %s))" path - (String.concat ~sep:"\n " l) - - let progn l = sprintf "(progn %s)" (String.concat ~sep:"\n" l) - - let echo s = sprintf "(echo %S)" s - - let write_file path content = sprintf "(write-file %S %S)" path content - - let run l = - sprintf "(run %s)" (List.map ~f:(sprintf "%S") l |> String.concat ~sep:" ") - - let install ?(section = "bin") ~package ?(files = []) () = - sprintf - "(install ((section %s)\n\ - \ (package %s)\n\ - \ (files (\n\ - %s\n\ - ))))" - section package - ( List.map files ~f:(function `As (a, b) -> sprintf " (%s as %s)" a b ) - |> String.concat ~sep:"\n" ) - - let lib ?(deps = []) ?(internal = false) name = - sprintf "(library ((name %s) %s (libraries (%s)) ))" name - ( if internal then "" - else - sprintf "(public_name %s)" - (String.map name ~f:(function '_' -> '-' | c -> c)) ) - (String.concat deps ~sep:" ") -end - -module Opam = struct - type qualifier = - [`Build | `Version of [`GT] * string | `And of qualifier * qualifier] - - let qualifier_to_string q = - let rec go = function - | `And (a, b) -> sprintf "%s & %s" (go a) (go b) - | `Build -> "build" - | `Version (`GT, s) -> sprintf ">= %S" s - in - sprintf "{%s}" (go q) - - let dep ?qualify ?(build = false) n = - sprintf "%S%s" n - ( match (qualify, build) with - | None, false -> "" - | None, true -> " " ^ qualifier_to_string `Build - | Some q, false -> " " ^ qualifier_to_string q - | Some q, true -> " " ^ qualifier_to_string (`And (`Build, q)) ) - - let obvious_deps = [dep "jbuilder" ~build:true; dep "ocamlfind" ~build:true] - - let make ?(opam_version = "1.2") ~maintainer ?authors ?(deps = obvious_deps) - ~homepage ?bug_reports ?dev_repo ?(license = "ISC") ?version - ?(ocaml_min_version = "4.03.0") ?(configure_script = "please.mlt") name = - let string k v = sprintf "%s: %S" k v in - let opt_default o d = match o with None -> d | Some s -> s in - let opt_f f k v = match v with None -> [] | Some s -> [f k s] in - (let opt_string k v = opt_f string k v in - [ sprintf "# This Opam file was auto-generated, see the `%s` script." - configure_script - ; string "opam-version" opam_version - ; string "maintainer" maintainer - ; (match authors with None -> [maintainer] | Some l -> l) - |> List.map ~f:(sprintf "%S") - |> String.concat ~sep:"\n " - |> sprintf "authors: [\n %s\n]" - ; string "homepage" homepage - ; string "bug-reports" (opt_default bug_reports (homepage // "issues")) - ; string "dev-repo" (opt_default dev_repo (homepage ^ ".git")) - ; string "license" license ] - @ opt_string "version" version) - @ [ sprintf "available: [ ocaml-version >= %S ]" ocaml_min_version - ; sprintf - "build: [\n\ - \ [\"ocaml\" %S \"configure\"]\n\ - \ [\"jbuilder\" \"build\" \"-p\" %S \"-j\" jobs ]\n\ - ]" - configure_script name - ; sprintf "depends: [\n%s\n]" - (List.map ~f:(sprintf " %s") deps |> String.concat ~sep:"\n") ] - - let v2 ~maintainer ?authors ?(deps = obvious_deps) ~homepage ?bug_reports - ?dev_repo ?(license = "ISC") ?version ?(ocaml_min_version = "4.03.0") - ?(configure_script = "please.mlt") ?synopsis ?description name = - let string k v = sprintf "%s: %S" k v in - let opt_default o d = match o with None -> d | Some s -> s in - let opt_f f k v = match v with None -> [] | Some s -> [f k s] in - (let opt_string k v = opt_f string k v in - [ sprintf "# This Opam file was auto-generated, see the `%s` script." - configure_script - ; string "opam-version" "2.0" - ; string "maintainer" maintainer - ; (match authors with None -> [maintainer] | Some l -> l) - |> List.map ~f:(sprintf "%S") - |> String.concat ~sep:"\n " - |> sprintf "authors: [\n %s\n]" - ; string "homepage" homepage - ; string "bug-reports" (opt_default bug_reports (homepage // "issues")) - ; string "dev-repo" (opt_default dev_repo ("git+" ^ homepage ^ ".git")) - ; string "license" license ] - @ opt_string "version" version) - @ [ sprintf - "build: [\n\ - \ [\"ocaml\" %S \"configure\"]\n\ - \ [\"jbuilder\" \"build\" \"-p\" %S \"-j\" jobs ]\n\ - ]" - configure_script name - ; sprintf "depends: [\n%s\n]" - ( sprintf " \"ocaml\" { >= %S }" ocaml_min_version - :: List.map ~f:(sprintf " %s") deps - |> String.concat ~sep:"\n" ) ] - @ opt_f (sprintf "%s: %S") "synopsis" synopsis - @ opt_f (sprintf "%s: \"\"\"\n%s\n\"\"\"") "description" description -end - -module File = struct - type t = {path: string; content: string list; no_clean: bool} - - let make ?(no_clean = false) path content = {path; content; no_clean} - - let file = make - - let repo_file = make ~no_clean:true -end - -module Main = struct - let make ?(command = "ocaml " ^ Sys.argv.(0)) ~files ?(argv = Sys.argv) - ?version ?describe ?(more_commands = []) () = - let usage () = - eprintf - "usage: %s {clean,configure,version ,describe %s}\n%!" - command - ( List.map more_commands ~f:(fun (k, _) -> sprintf ",%s" k) - |> String.concat ~sep:"" ) - in - match argv.(1) with - | "clean" -> - List.iter files ~f:(function - | {File.no_clean= false; path; _} -> - Util.cmdf "rm -f %s" (Filename.quote path) - | _ -> () ) - | "configure" -> - List.iter files ~f:(fun {File.path; content} -> - Util.cmdf "mkdir -p %s" Filename.(dirname path |> quote) ; - Util.write_lines path content ) ; - () - | "describe" -> ( - match describe with - | None -> failwith "describe function not defined" - | Some f -> ( try f (Some Sys.argv.(2)) with _ -> f None ) ) - | "version" -> ( - match version with - | None -> failwith "version function not defined" - | Some f -> ( try f (Some Sys.argv.(2)) with _ -> f None ) ) - | other -> ( - match List.find more_commands ~f:(fun (k, v) -> k = other) with - | _, f -> f () - | exception _ -> - eprintf "Cannot understand command: %S\n%!" other ; - usage () ; - exit 1 ) - | exception _ -> - eprintf "Missing command\n" ; - usage () ; - exit 1 -end diff --git a/tools/travis_ci_test.sh b/tools/travis_ci_test.sh index 488305d..2f5e9a3 100644 --- a/tools/travis_ci_test.sh +++ b/tools/travis_ci_test.sh @@ -4,7 +4,7 @@ travis_install_on_linux () { # Install OCaml and OPAM PPAs - export ppa=avsm/ocaml42+opam12 + export ppa=avsm/ppa echo "yes" | sudo add-apt-repository ppa:$ppa sudo apt-get update -qq @@ -79,7 +79,7 @@ echo "$(xargs --show-limits & { sleep 1 ; exit 0 ; } )" echo ">>> ULimits:" ulimit -a -bash ./tools/env-var-tst.sh +# bash ./tools/env-var-tst.sh # install OCaml packages opam init $opam_init_options @@ -88,35 +88,34 @@ eval `opam config env` opam update # Extra dependency for the tests: -opam install --yes uri +opam install --yes uri nonstd sosa opam pin add genspio . opam install genspio export OCAMLPARAM='warn-error=Ad-58,_' -genspio_test=_build/default/src/test/main.exe -genspio_downloader_maker=_build/default/src/examples/downloader.exe -genspio_small_examples=_build/default/src/examples/small_examples.exe -genspio_vm_tester=_build/default/src/examples/vm_tester.exe -genspio_service_composer=_build/default/src/examples/service_composer.exe -genspio_multigit=_build/default/src/examples/multigit.exe +genspio_test=src/test/main.exe +genspio_downloader_maker=src/examples/downloader.exe +genspio_small_examples=src/examples/small_examples.exe +genspio_vm_tester=src/examples/vm_tester.exe +genspio_service_composer=src/examples/service_composer.exe +genspio_multigit=src/examples/multigit.exe echo "================== BUILD ALL ===================================================" -ocaml please.mlt configure -jbuilder build @install +dune build @install -jbuilder build $genspio_test -jbuilder build $genspio_downloader_maker -jbuilder build $genspio_small_examples -jbuilder build $genspio_vm_tester -jbuilder build $genspio_service_composer -jbuilder build $genspio_multigit +dune build $genspio_test +dune build $genspio_downloader_maker +dune build $genspio_small_examples +dune build $genspio_vm_tester +dune build $genspio_service_composer +dune build $genspio_multigit echo "================== TESTS =======================================================" -$genspio_test --run-constant-propagation-tests \ - --important-shells $important_shells _test/ +dune exec $genspio_test -- --run-constant-propagation-tests \ + --important-shells $important_shells _test/ ( cd _test case $TRAVIS_OS_NAME in @@ -145,7 +144,7 @@ $genspio_test --run-constant-propagation-tests \ echo "================== EXAMPLES: TEST 1 ============================================" genspio_downloader=/tmp/genspio-downloader -$genspio_downloader_maker make $genspio_downloader +dune exec $genspio_downloader_maker -- make $genspio_downloader $main_shell $genspio_downloader -h @@ -172,22 +171,22 @@ echo "================== EXAMPLES: TEST 3 ====================================== echo "================== EXAMPLES: SMALL ONES ============================================" -$genspio_small_examples +dune exec $genspio_small_examples echo "================== EXAMPLES: vm_tester ============================================" -$genspio_vm_tester --vm arm-owrt /tmp/vmt/arm-owrt/ ; ( cd /tmp/vmt/arm-owrt/ ; make help ; ) -$genspio_vm_tester --vm arm-dw /tmp/vmt/arm-dw/ ; ( cd /tmp/vmt/arm-dw/ ; make help ; ) -$genspio_vm_tester --vm amd64-fb /tmp/vmt/amd64-fb/ ; ( cd /tmp/vmt/amd64-fb ; make help ; ) +dune exec $genspio_vm_tester -- --vm arm-owrt /tmp/vmt/arm-owrt/ ; ( cd /tmp/vmt/arm-owrt/ ; make help ; ) +dune exec $genspio_vm_tester -- --vm arm-dw /tmp/vmt/arm-dw/ ; ( cd /tmp/vmt/arm-dw/ ; make help ; ) +dune exec $genspio_vm_tester -- --vm amd64-fb /tmp/vmt/amd64-fb/ ; ( cd /tmp/vmt/amd64-fb ; make help ; ) echo "================== EXAMPLES: Service-composer=======================================" -$genspio_service_composer --name cosc --output-path $HOME/bin +dune exec $genspio_service_composer -- --name cosc --output-path $HOME/bin echo "================== EXAMPLES: Multigit =======================================" -$genspio_multigit $HOME/bin +dune exec $genspio_multigit -- $HOME/bin export PATH=$HOME/bin:$PATH ./tools/multigit-test.sh