diff --git a/.ocamlformat b/.ocamlformat index f946cc0..c365faf 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.25.1 +version=0.27.0 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/dune-project b/dune-project index 710624a..8f26d8c 100644 --- a/dune-project +++ b/dune-project @@ -31,10 +31,11 @@ (tags (scfg configuration format simple config parser printer)) (depends - (ocaml - (>= 4.13)) + cmdliner (menhir (>= 20211230)) + (ocaml + (>= 4.13)) sedlex)) (using menhir 2.1) diff --git a/example/dune b/example/dune index 99c92f7..8efe969 100644 --- a/example/dune +++ b/example/dune @@ -1,4 +1,4 @@ (executable (name main) (modules main) - (libraries scfg)) + (libraries fpath scfg)) diff --git a/example/main.ml b/example/main.ml index 5aa8901..55a21f2 100644 --- a/example/main.ml +++ b/example/main.ml @@ -1,26 +1,34 @@ (* run on the `main.scfg` file in this directory *) let () = if Array.length Sys.argv <> 2 then begin - Format.eprintf "usage: %s @." Sys.argv.(0); + Format.eprintf "usage: %s @\n" Sys.argv.(0); exit 1 - end; + end - (* parsing the file *) - let config = - match Scfg.Parse.from_file Sys.argv.(1) with - | Error e -> - Format.eprintf "error: %s@." e; - exit 1 - | Ok config -> config - in +(* parsing file path *) +let filepath = + match Fpath.of_string Sys.argv.(1) with + | Error (`Msg e) -> + Format.eprintf "error: %s@\n" e; + exit 1 + | Ok path -> path - (* printing the file *) - Format.printf "```scfg@.%a@.```@." Scfg.Pp.config config; +(* parsing the file *) +let config = + match Scfg.Parse.from_file filepath with + | Error (`Msg e) -> + Format.eprintf "error: %s@\n" e; + exit 1 + | Ok config -> config - (* querying the file *) +(* printing the file *) +let () = Format.printf "```scfg@\n%a@\n```@\n" Scfg.Pp.config config + +(* querying the file *) +let () = match Scfg.Query.get_dir "train" config with - | None -> Format.printf "No train found.@." + | None -> Format.printf "No train found.@\n" | Some train -> ( match Scfg.Query.get_param 0 train with - | Error _e -> Format.printf "Train has no name.@." - | Ok name -> Format.printf "The first train is `%s`.@." name ) + | Error _e -> Format.printf "Train has no name.@\n" + | Ok name -> Format.printf "The first train is `%s`.@\n" name ) diff --git a/scfg.opam b/scfg.opam index 575c27c..68deaa4 100644 --- a/scfg.opam +++ b/scfg.opam @@ -13,8 +13,9 @@ doc: "https://doc.zapashcanon.fr/scfg" bug-reports: "https://git.zapashcanon.fr/zapashcanon/scfg/issues" depends: [ "dune" {>= "2.8"} - "ocaml" {>= "4.13"} + "cmdliner" "menhir" {>= "20211230"} + "ocaml" {>= "4.13"} "sedlex" "odoc" {with-doc} ] diff --git a/src/dune b/src/dune index 10b3989..3897488 100644 --- a/src/dune +++ b/src/dune @@ -4,14 +4,19 @@ (private_modules lexer menhir_parser) (preprocess (pps sedlex.ppx)) - (libraries menhirLib sedlex) + (libraries menhirLib prelude sedlex) + (flags + (:standard -open Prelude)) (instrumentation (backend bisect_ppx))) (executable (public_name scfg) (modules scfg) - (libraries scfg)) + (flags + (:standard -open Prelude)) + (libraries cmdliner prelude scfg)) (menhir + (flags --table) (modules menhir_parser)) diff --git a/src/lexer.ml b/src/lexer.ml index 96a514d..b113aaa 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -31,7 +31,7 @@ let string_of_atom s = let i = ref 0 in while !i < String.length s do let c = - if s.[!i] <> '\\' then s.[!i] + if not @@ Char.equal '\\' s.[!i] then s.[!i] else match incr i; @@ -57,7 +57,7 @@ let string_of_dqword s = let i = ref 0 in while !i < String.length s do let c = - if s.[!i] <> '\\' then s.[!i] + if not @@ Char.equal '\\' s.[!i] then s.[!i] else match incr i; @@ -104,9 +104,8 @@ let rec token buf = | any -> let invalid = Utf8.lexeme buf in let start, _stop = Sedlexing.lexing_positions buf in - Format.ksprintf error - "File %s, line %i, character %i: unexpected lexeme `%s`" start.pos_fname - start.pos_lnum + Fmt.kstr error "File %s, line %i, character %i: unexpected lexeme `%s`" + start.pos_fname start.pos_lnum (start.pos_cnum - start.pos_bol) invalid | _ -> assert false diff --git a/src/parse.ml b/src/parse.ml index fb6d817..cda15bb 100644 --- a/src/parse.ml +++ b/src/parse.ml @@ -2,11 +2,11 @@ (** Pretty print a token *) let pp_token fmt = function - | Menhir_parser.WORD s -> Format.fprintf fmt "WORD %s" s - | LBRACE -> Format.pp_print_string fmt "LBRACE" - | RBRACE -> Format.pp_print_string fmt "RBRACE" - | NEWLINE -> Format.pp_print_string fmt "NEWLINE" - | EOF -> Format.pp_print_string fmt "EOF" + | Menhir_parser.WORD s -> Fmt.pf fmt "WORD %s" s + | LBRACE -> Fmt.string fmt "LBRACE" + | RBRACE -> Fmt.string fmt "RBRACE" + | NEWLINE -> Fmt.string fmt "NEWLINE" + | EOF -> Fmt.string fmt "EOF" (** Parse a config from a lexing buffer. *) let from_lexbuf = @@ -24,13 +24,11 @@ let from_lexbuf = try Ok (parser provider) with | Menhir_parser.Error -> let start, _stop = Sedlexing.lexing_positions buf in - Format.kasprintf Result.error - "File %s, line %i, character %i: unexpected token %a" start.pos_fname - start.pos_lnum + Fmt.error_msg "File %s, line %i, character %i: unexpected token %a" + start.pos_fname start.pos_lnum (start.pos_cnum - start.pos_bol) - (Format.pp_print_option pp_token) - !last_token - | Lexer.Error msg -> Error msg + (Fmt.option pp_token) !last_token + | Lexer.Error msg -> Error (`Msg msg) (** Parse a config from a string. *) let from_string s = from_lexbuf (Sedlexing.Utf8.from_string s) @@ -48,9 +46,14 @@ let from_channel c = from_lexbuf (Sedlexing.Utf8.from_channel c) (** Parse a config from a file. *) let from_file f = - let chan = open_in f in - let lexbuf = Sedlexing.Utf8.from_channel chan in - Sedlexing.set_filename lexbuf f; - let result = from_lexbuf lexbuf in - close_in chan; - result + match + Bos.OS.File.with_ic f + (fun chan () -> + let lexbuf = Sedlexing.Utf8.from_channel chan in + Sedlexing.set_filename lexbuf (Fpath.to_string f); + from_lexbuf lexbuf ) + () + with + | Error _ as e -> e + | Ok (Error _ as e) -> e + | Ok (Ok _ as ok) -> ok diff --git a/src/pp.ml b/src/pp.ml index 02a1e14..ad6e398 100644 --- a/src/pp.ml +++ b/src/pp.ml @@ -7,13 +7,13 @@ open Types let param = let chars_to_quote = Hashtbl.create 512 in Array.iter - (fun c -> Hashtbl.add chars_to_quote c ()) + (fun c -> Hashtbl.replace chars_to_quote c ()) [| ' '; '{'; '}'; '"'; '\\'; '\''; '\n'; '\r'; '\t' |]; fun fmt param -> - if String.length param = 0 then Format.fprintf fmt {|""|} + if String.length param = 0 then Fmt.string fmt {|""|} else if String.exists (Hashtbl.mem chars_to_quote) param then begin if String.contains param '"' && not (String.contains param '\'') then - Format.fprintf fmt {|'%s'|} param + Fmt.pf fmt {|'%s'|} param else let buf = Buffer.create (String.length param) in String.iter @@ -26,32 +26,27 @@ let param = | c -> Buffer.add_char buf c ) param; let param = Buffer.contents buf in - Format.fprintf fmt {|"%s"|} param + Fmt.pf fmt {|"%s"|} param end - else Format.fprintf fmt "%s" param + else Fmt.string fmt param (** Print a list of parameters on a given formatter. *) let params fmt = function | [] -> () | params -> - Format.fprintf fmt " %a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt " ") - param ) + Fmt.pf fmt " %a" + (Fmt.list ~sep:(fun fmt () -> Fmt.string fmt " ") param) params (** Print children of a directive on a given formatter. *) -let rec children fmt (children : Types.directive list) = - match children with +let rec children fmt = function | [] -> () - | children -> Format.fprintf fmt " {@\n @[%a@]@\n}" config children + | children -> Fmt.pf fmt " {@\n @[%a@]@\n}" config children (** Print a directive on a given formatter. *) and directive fmt d = - Format.fprintf fmt {|%a%a%a|} param d.name params d.params children d.children + Fmt.pf fmt {|%a%a%a|} param d.name params d.params children d.children (** Print a config on a given formatter. *) and config fmt (config : Types.config) = - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - directive fmt config + Fmt.list ~sep:(fun fmt () -> Fmt.pf fmt "@\n") directive fmt config diff --git a/src/query.ml b/src/query.ml index b837e1d..dc55b65 100644 --- a/src/query.ml +++ b/src/query.ml @@ -5,124 +5,121 @@ open Types (** Returns a list of directives with the provided name from a list of directives. *) let get_dirs name directives = - List.filter (fun directive -> directive.name = name) directives + List.filter (fun directive -> String.equal directive.name name) directives -(** Returns the first directive with the provided name from a list of directive. *) +(** Returns the first directive with the provided name from a list of directive. +*) let get_dir name directives = - List.find_opt (fun directive -> directive.name = name) directives + List.find (fun directive -> String.equal directive.name name) directives (** Same as [get_dir] but raises if no directive is found. *) let get_dir_exn name directives = match get_dir name directives with - | None -> Format.kasprintf failwith "missing directive %a" Pp.param name + | None -> Fmt.failwith "missing directive %a" Pp.param name | Some dir -> dir (** Extract a given number of parameters from a directive. *) let get_params n directive = let len = List.length directive.params in if len < n then - Error - (Format.asprintf "directive %a: want %d params, got only %d" Pp.param - directive.name n len ) + Fmt.error_msg "directive %a: want %d params, got only %d" Pp.param + directive.name n len else Ok (List.filteri (fun i _param -> i < n) directive.params) (** Extract a parameter at a given index from a directive. *) let get_param n directive = let params = directive.params in - match List.nth_opt params n with + match List.nth params n with | None -> - Error - (Format.asprintf "directive %a: want param at index %d, got only %d" - Pp.param directive.name n (List.length params) ) + Fmt.error_msg "directive %a: want param at index %d, got only %d" Pp.param + directive.name n (List.length params) | Some param -> Ok param (** Same as [get_param] but raises if an error occurs. *) let get_param_exn n directive = - match get_param n directive with Ok v -> v | Error msg -> failwith msg + match get_param n directive with + | Ok v -> v + | Error (`Msg msg) -> Fmt.failwith "%s" msg (** Extract a bool parameter at a given index from a directive. *) let get_param_bool n directive = let params = directive.params in - match List.nth_opt params n with + match List.nth params n with | None -> - Error - (Format.asprintf "directive %a: want param at index %d, got only %d" - Pp.param directive.name n (List.length params) ) + Fmt.error_msg "directive %a: want param at index %d, got only %d" Pp.param + directive.name n (List.length params) | Some param -> ( try Ok (bool_of_string param) with Invalid_argument _msg -> - Error - (Format.asprintf - "directive %a: want bool param at index %d, but got `%s`" Pp.param - directive.name n param ) ) + Fmt.error_msg "directive %a: want bool param at index %d, but got `%s`" + Pp.param directive.name n param ) (** Same as [get_param_bool] but raises if an error occurs. *) let get_param_bool_exn n directive = - match get_param_bool n directive with Ok v -> v | Error msg -> failwith msg + match get_param_bool n directive with + | Ok v -> v + | Error (`Msg msg) -> Fmt.failwith "%s" msg (** Extract an int parameter at a given index from a directive. *) let get_param_int n directive = let params = directive.params in - match List.nth_opt params n with + match List.nth params n with | None -> - Error - (Format.asprintf "directive %a: want param at index %d, got only %d" - Pp.param directive.name n (List.length params) ) + Fmt.error_msg "directive %a: want param at index %d, got only %d" Pp.param + directive.name n (List.length params) | Some param -> ( try Ok (int_of_string param) with Invalid_argument _msg -> - Error - (Format.asprintf "directive %a: want int param at index %d, but got %s" - Pp.param directive.name n param ) ) + Fmt.error_msg "directive %a: want int param at index %d, but got %s" + Pp.param directive.name n param ) (** Same as [get_param_int] but raises if an error occurs. *) let get_param_int_exn n directive = - match get_param_int n directive with Ok v -> v | Error msg -> failwith msg + match get_param_int n directive with + | Ok v -> v + | Error (`Msg msg) -> Fmt.failwith "%s" msg (** Extract a positive int parameter at a given index from a directive. *) let get_param_pos_int n directive = let params = directive.params in - match List.nth_opt params n with + match List.nth params n with | None -> - Error - (Format.asprintf "directive %a: want param at index %d, got only %d" - Pp.param directive.name n (List.length params) ) + Fmt.error_msg "directive %a: want param at index %d, got only %d" Pp.param + directive.name n (List.length params) | Some param -> ( - try - let n = int_of_string param in + match int_of_string param with + | None -> + Fmt.error_msg "directive %a: want int param at index %d, but got %s" + Pp.param directive.name n param + | Some n -> if n < 0 then - Error - (Format.asprintf - "directive %a: want positive int param at index %d, but got %d" - Pp.param directive.name n n ) - else Ok n - with Invalid_argument _msg -> - Error - (Format.asprintf "directive %a: want int param at index %d, but got %s" - Pp.param directive.name n param ) ) + Fmt.error_msg + "directive %a: want positive int param at index %d, but got %d" + Pp.param directive.name n n + else Ok n ) (** Same as [get_param_pos_int] but raises if an error occurs. *) let get_param_pos_int_exn n directive = match get_param_pos_int n directive with | Ok v -> v - | Error msg -> failwith msg + | Error (`Msg msg) -> Fmt.failwith "%s" msg - - (** Extract a float parameter at a given index from a directive. *) +(** Extract a float parameter at a given index from a directive. *) let get_param_float n directive = let params = directive.params in - match List.nth_opt params n with + match List.nth params n with | None -> - Error - (Format.asprintf "directive %a: want param at index %d, got only %d" - Pp.param directive.name n (List.length params) ) + Fmt.error_msg "directive %a: want param at index %d, got only %d" Pp.param + directive.name n (List.length params) | Some param -> ( - try Ok (float_of_string param) - with Invalid_argument _msg -> - Error - (Format.asprintf "directive %a: want float param at index %d, but got %s" - Pp.param directive.name n param ) ) + match float_of_string param with + | None -> + Fmt.error_msg "directive %a: want float param at index %d, but got %s" + Pp.param directive.name n param + | Some f -> Ok f ) (** Same as [get_param_float] but raises if an error occurs. *) let get_param_float_exn n directive = - match get_param_float n directive with Ok v -> v | Error msg -> failwith msg + match get_param_float n directive with + | Ok v -> v + | Error (`Msg msg) -> Fmt.failwith "%s" msg diff --git a/src/scfg.ml b/src/scfg.ml index bb3a475..e7b0a58 100644 --- a/src/scfg.ml +++ b/src/scfg.ml @@ -1,20 +1,28 @@ -open Scfg +open Cmdliner -let error msg = - Format.eprintf "error: %s@." msg; - exit 1 +(* Helpers *) +let existing_file_conv = Arg.conv (Fpath.of_string, Fpath.pp) -let () = - if Array.length Sys.argv <> 2 then - error (Format.sprintf "usage: %s " Sys.argv.(0)); +(* Terms *) +let config = + let doc = "Input file" in + Arg.(required & pos 0 (some existing_file_conv) None (info [] ~doc)) - let file = Sys.argv.(1) in - - if not @@ Sys.file_exists file then - error (Format.sprintf "file `%s` doesn't exist" file); - - match Parse.from_file file with - | Ok config -> Format.printf "%a@." Pp.config config - | Error e -> - Format.eprintf "error: %s@." e; +(* Command *) +let pp_cmd = + let open Term.Syntax in + let+ config in + match Scfg.Parse.from_file config with + | Error (`Msg e) -> + Fmt.epr "%s" e; exit 1 + | Ok config -> Fmt.pr "%a@." Scfg.Pp.config config + +let pp_info = + let doc = "Format scfg files." in + let man = [ `S Manpage.s_bugs; `P "Léo Andrès " ] in + Cmd.info "scfg" ~version:"%%VERSION%%" ~doc ~man + +let cli = Cmd.v pp_info pp_cmd + +let () = exit @@ Cmdliner.Cmd.eval cli diff --git a/test/cram/test.t b/test/cram/test.t index fbcc228..4022cb1 100644 --- a/test/cram/test.t +++ b/test/cram/test.t @@ -25,23 +25,23 @@ test 2: } lex error 1: $ dune exec -- scfg lex_error.scfg - error: File lex_error.scfg, line 1, character 2: unexpected lexeme `"` + File lex_error.scfg, line 1, character 2: unexpected lexeme `"` [1] parse error 1: $ dune exec -- scfg parse_error1.scfg - error: File parse_error1.scfg, line 1, character 2: unexpected lexeme `{` + File parse_error1.scfg, line 1, character 2: unexpected lexeme `{` [1] parse error 2: $ dune exec -- scfg parse_error2.scfg - error: File parse_error2.scfg, line 2, character 0: unexpected token EOF + File parse_error2.scfg, line 2, character 0: unexpected token EOF [1] parse error 3: $ dune exec -- scfg parse_error3.scfg - error: File parse_error3.scfg, line 1, character 2: unexpected lexeme `}` + File parse_error3.scfg, line 1, character 2: unexpected lexeme `}` [1] parse error 4: $ dune exec -- scfg parse_error4.scfg - error: File parse_error4.scfg, line 1, character 2: unexpected lexeme `{` + File parse_error4.scfg, line 1, character 2: unexpected lexeme `{` [1] bug 1: $ dune exec -- scfg bug1.scfg diff --git a/test/fuzz/dune b/test/fuzz/dune index c48b604..2925ca3 100644 --- a/test/fuzz/dune +++ b/test/fuzz/dune @@ -1,4 +1,6 @@ (executable (name fuzz) (modules fuzz gen) - (libraries crowbar scfg)) + (flags + (:standard -open Prelude)) + (libraries crowbar prelude scfg)) diff --git a/test/fuzz/fuzz.ml b/test/fuzz/fuzz.ml index 35e3b30..77b154f 100644 --- a/test/fuzz/fuzz.ml +++ b/test/fuzz/fuzz.ml @@ -4,15 +4,15 @@ let () = Random.self_init () let () = Crowbar.add_test ~name:"Print and parse fuzzing" [ Gen.config ] (fun config -> - let printed = Format.asprintf "%a" Pp.config config in + let printed = Fmt.str "%a" Pp.config config in match Parse.from_string printed with - | Error msg -> + | Error (`Msg msg) -> Crowbar.failf "%s on the given input@\n***`%S`@\n***`%s`@\n" msg printed printed | Ok config -> ( - let printed = Format.asprintf "%a" Pp.config config in + let printed = Fmt.str "%a" Pp.config config in match Parse.from_string printed with - | Error msg -> + | Error (`Msg msg) -> Crowbar.failf "%s on the given input@\n***`%S`@\n***`%s`@\n" msg printed printed | Ok parsed -> Crowbar.check_eq ~pp:Pp.config config parsed ) ) diff --git a/test/unit/dune b/test/unit/dune index 4ac20f3..c220162 100644 --- a/test/unit/dune +++ b/test/unit/dune @@ -1,5 +1,5 @@ (test (name main) (modules main) - (libraries scfg) + (libraries prelude scfg) (deps query.scfg test_chan.scfg)) diff --git a/test/unit/main.ml b/test/unit/main.ml index 67fb7d6..371a395 100644 --- a/test/unit/main.ml +++ b/test/unit/main.ml @@ -13,7 +13,7 @@ let () = let () = let s = {|a b c|} in match Parse.from_string s with - | Error e -> + | Error (`Msg e) -> Format.eprintf "ERROR: %s@\n" e; assert false | Ok config -> @@ -22,9 +22,14 @@ let () = assert (s = expected) (** Testing queries. *) +let file = + match Fpath.of_string "query.scfg" with + | Error _e -> assert false + | Ok file -> file + let () = let config = - match Parse.from_file "query.scfg" with + match Parse.from_file file with | Error _e -> assert false | Ok config -> config in @@ -46,7 +51,7 @@ let () = assert (pn12 = [ "p1"; "p2" ]); begin match Query.get_params 3 n12 with - | Error "directive n1.2: want 3 params, got only 2" -> () + | Error (`Msg "directive n1.2: want 3 params, got only 2") -> () | Error _ | Ok _ -> assert false end; begin @@ -55,7 +60,7 @@ let () = | Ok p -> assert (p = "p1") end; match Query.get_param 5 n12 with - | Error "directive n1.2: want param at index 5, got only 2" -> () + | Error (`Msg "directive n1.2: want param at index 5, got only 2") -> () | Error _ | Ok _ -> assert false let () = Format.printf "all tests OK! 🐱"