zapashcanon/scfg
1
0
Fork 1
Code Issues Pull Requests Actions Projects Releases Wiki Activity

switch to prelude and cmdliner, update fmt

Browse Source
This commit is contained in:
zapashcanon 2025-01-03 19:50:43 +01:00
parent 82afee114d
commit d68bd5d35f
Signed by: zapashcanon
GPG Key ID: 8981C3C62D1D28F1
16 changed files with 173 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ocamlformat
View File

@ -1,4 +1,4 @@
version=0.25.1
version=0.27.0
assignment-operator=end-line
break-cases=fit
break-fun-decl=wrap

5
dune-project
View File

@ -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)

2
example/dune
View File

@ -1,4 +1,4 @@
(executable
(name main)
(modules main)
(libraries scfg))
(libraries fpath scfg))

40
example/main.ml
View File

@ -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 <scfg file>@." Sys.argv.(0);
Format.eprintf "usage: %s <scfg file>@\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 )

3
scfg.opam
View File

@ -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}
]

9
src/dune
View File

@ -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))

9
src/lexer.ml
View File

@ -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

37
src/parse.ml
View File

@ -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

27
src/pp.ml
View File

@ -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 @[<v>%a@]@\n}" config children
| children -> Fmt.pf fmt " {@\n @[<v>%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

111
src/query.ml
View File

@ -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

40
src/scfg.ml
View File

@ -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 <file>" 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 <contact@ndrs.fr>" ] in
Cmd.info "scfg" ~version:"%%VERSION%%" ~doc ~man
let cli = Cmd.v pp_info pp_cmd
let () = exit @@ Cmdliner.Cmd.eval cli

10
test/cram/test.t
View File

@ -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

4
test/fuzz/dune
View File

@ -1,4 +1,6 @@
(executable
(name fuzz)
(modules fuzz gen)
(libraries crowbar scfg))
(flags
(:standard -open Prelude))
(libraries crowbar prelude scfg))

8
test/fuzz/fuzz.ml
View File

@ -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 ) )

2
test/unit/dune
View File

@ -1,5 +1,5 @@
(test
(name main)
(modules main)
(libraries scfg)
(libraries prelude scfg)
(deps query.scfg test_chan.scfg))

13
test/unit/main.ml
View File

@ -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! 🐱"