swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-10-13 09:56:03 +02:00
parent e58398bee5
commit 9f452d257a
1 changed files with 93 additions and 91 deletions
Download patch file Download diff file Expand all files Collapse all files

184
include/parse_config.ml
View file

@ -38,121 +38,123 @@ let duration_value =
let read_file file = In_channel.with_open_bin file In_channel.input_all
type item = {
key: string;
value: string;
}
module Untyped = struct
type item = {
key: string;
value: string;
}
type line =
| Blank
| Comment of string
| Header of string
| Item of item
type line =
| Blank
| Comment of string
| Header of string
| Item of item
type section = {
header: string;
items: item list;
}
type section = {
header: string;
items: item list;
}
open Angstrom
open Angstrom
let is_eol = function '\n' | '\r' -> true | _ -> false
let is_whitespace = function ' ' | '\t' -> true | _ -> false
let whitespace = skip_while is_whitespace
let is_eol = function '\n' | '\r' -> true | _ -> false
let is_whitespace = function ' ' | '\t' -> true | _ -> false
let whitespace = skip_while is_whitespace
let id =
let ident_char = function
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true
| _ -> false
in
take_while1 ident_char >>| String.lowercase_ascii
let id =
let ident_char = function
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true
| _ -> false
in
take_while1 ident_char >>| String.lowercase_ascii
let take_till_end_of_line =
take_till is_eol >>= fun s -> return s <* end_of_line
let take_till_end_of_line =
take_till is_eol >>= fun s -> return s <* end_of_line
let blank = whitespace <* end_of_line >>| fun () -> Blank
let blank = whitespace <* end_of_line >>| fun () -> Blank
let comment =
whitespace *> (char '#' <|> char '%') *> take_till_end_of_line >>| fun s ->
Comment s
let comment =
whitespace *> (char '#' <|> char '%') *> take_till_end_of_line >>| fun s ->
Comment s
let header = char '[' *> id <* char ']' <* end_of_line >>| fun s -> Header s
let header = char '[' *> id <* char ']' <* end_of_line >>| fun s -> Header s
let item_value =
let unquoted_value =
take_while1 (fun c -> not (is_whitespace c || is_eol c))
in
let quoted_value =
char '"' *> take_till is_eol >>= fun s ->
match String.ends_with ~suffix:"\"" s with
| false -> fail "invalid quoted value"
| true ->
let value = String.sub s 0 (String.length s - 1) in
return value
in
quoted_value <|> unquoted_value
let item_value =
let unquoted_value =
take_while1 (fun c -> not (is_whitespace c || is_eol c))
in
let quoted_value =
char '"' *> take_till is_eol >>= fun s ->
match String.ends_with ~suffix:"\"" s with
| false -> fail "invalid quoted value"
| true ->
let value = String.sub s 0 (String.length s - 1) in
return value
in
quoted_value <|> unquoted_value
let item =
lift2
(fun key value -> Item { key; value })
id
(whitespace *> char '=' *> whitespace *> item_value)
<* end_of_line
let item =
lift2
(fun key value -> Item { key; value })
id
(whitespace *> char '=' *> whitespace *> item_value)
<* end_of_line
let config = many (choice [ blank; comment; header; item ]) <* end_of_input
let config = many (choice [ blank; comment; header; item ]) <* end_of_input
let fold_sections l =
let rec loop section_l item_l l =
match l with
| [] ->
if List.is_empty item_l then section_l
else Fmt.failwith "invalid config structure"
| Blank :: tl | Comment _ :: tl -> loop section_l item_l tl
| Item item :: tl -> loop section_l (item :: item_l) tl
| Header header :: tl ->
let section = { header; items= item_l } in
loop (section :: section_l) [] tl
in
loop [] [] (List.rev l)
let fold_sections l =
let rec loop section_l item_l l =
match l with
| [] ->
if List.is_empty item_l then section_l
else Fmt.failwith "invalid config structure"
| Blank :: tl | Comment _ :: tl -> loop section_l item_l tl
| Item item :: tl -> loop section_l (item :: item_l) tl
| Header header :: tl ->
let section = { header; items= item_l } in
loop (section :: section_l) [] tl
in
loop [] [] (List.rev l)
let parse s =
match parse_string ~consume:All config s with
| Error msg -> Fmt.failwith "config parse error: %s" msg
| Ok v -> fold_sections v
let parse s =
match parse_string ~consume:All config s with
| Error msg -> Fmt.failwith "config parse error: %s" msg
| Ok v -> fold_sections v
module Pp_debug = struct
let pp_item ppf { key; value } =
let open Fmt in
match String.contains value '"' || String.contains value ' ' with
| false -> pf ppf "%s = %s" key value
| true -> pf ppf "%s = \"%s\"" key value
module Pp_debug = struct
let pp_item ppf { key; value } =
let open Fmt in
match String.contains value '"' || String.contains value ' ' with
| false -> pf ppf "%s = %s" key value
| true -> pf ppf "%s = \"%s\"" key value
let pp_line ppf line =
let open Fmt in
match line with
| Blank -> Fmt.nop ppf ()
| Comment s -> pf ppf "#%s" s
| Header s -> pf ppf "[%s]" s
| Item item -> pf ppf "%a" pp_item item
let pp_line ppf line =
let open Fmt in
match line with
| Blank -> Fmt.nop ppf ()
| Comment s -> pf ppf "#%s" s
| Header s -> pf ppf "[%s]" s
| Item item -> pf ppf "%a" pp_item item
let _pp_lines ppf raw_line_l =
let open Fmt in
pf ppf "%a" (list ~sep:(any "\n") pp_line) raw_line_l
let _pp_lines ppf raw_line_l =
let open Fmt in
pf ppf "%a" (list ~sep:(any "\n") pp_line) raw_line_l
let pp_section ppf { header; items } =
let open Fmt in
pf ppf "[%s]@\n%a" header (list ~sep:(any "\n") pp_item) items
let pp_section ppf { header; items } =
let open Fmt in
pf ppf "[%s]@\n%a" header (list ~sep:(any "\n") pp_item) items
let pp_config ppf l =
let open Fmt in
pf ppf "%a" (list ~sep:(any "\n") pp_section) l
let pp_config ppf l =
let open Fmt in
pf ppf "%a" (list ~sep:(any "\n") pp_section) l
end
end
let () =
let content = read_file "default.config" in
(*Fmt.pr "%s" content;*)
let config = parse content in
let config = Untyped.parse content in
(*Fmt.pr "%a@." pp_lines config;*)
Fmt.pr "%a@." Pp_debug.pp_config config;
Fmt.pr "%a@." Untyped.Pp_debug.pp_config config;
()