diff options
Diffstat (limited to 'lib/configuration.ml')
| -rw-r--r-- | lib/configuration.ml | 29 |
1 files changed, 12 insertions, 17 deletions
diff --git a/lib/configuration.ml b/lib/configuration.ml index 420dff6..6f45de0 100644 --- a/lib/configuration.ml +++ b/lib/configuration.ml @@ -5,14 +5,13 @@ module type CONFIGURABLE = sig end module Error = struct - (* open Condition let unknown_section key = - condition "unknown-section" "Unknown configuration section" ("key" |=| of_string key) + condition "unknown-section" "Unknown configuration section" ("key" |=| Value.String key) let duplicate_section key = - condition "duplicate-section" "Duplicate configuration section" ("key" |=| of_string key) + condition "duplicate-section" "Duplicate configuration section" ("key" |=| Value.String key) let empty_section key = condition "empty-section" "Empty configuration section (expected a tagged value)" @@ -25,11 +24,11 @@ module Error = struct let invalid_toplevel toplevel = condition "invalid-toplevel" "Configuration must be a (server ...) s-expression" - ("expression" |=| of_sexp toplevel) + ("expression" |=| Value.String (Sexplib.Sexp.to_string toplevel)) let malformed_section expr = condition "malformed-section" "Section must be a (tag ...) s-expression" - ("expression" |=| of_sexp expr) + ("expression" |=| Value.String (Sexplib.Sexp.to_string expr)) let missing_section name = condition "missing-section" "Missing section in configuration" ("name" |=| Value.String name) @@ -38,7 +37,7 @@ module Error = struct condition "invalid-tag" "Invalid tag for section" ( "section" |=| Value.String section & "tag" |=| Value.String tag - & "valid-options" |=| of_list Value.String valid_options ) + & "valid-options" |=| Value.String (String.concat " " valid_options) ) let failed_to_load_file path msg = condition "failed-to-load-file" "Failed to load configuration file" @@ -46,19 +45,15 @@ module Error = struct let syntax_error path msg = condition "syntax-error" "Failed to parse configuration file" - ("path" |=| Value.String path & "message" |=| Value.String msg) - *) - + ("path" |=| Value.String path & "message" |=| Value.String msg) end -(* - (** Section name -> raw sexp subtree. *) type t = Sexplib.Sexp.t Utilities.StringMap.t let find_section (key : string) (config : t) : Sexplib.Sexp.t option = Utilities.StringMap.find_opt key config -( + (** Check that [key] is expected and not duplicate, then add it. *) let insert_section ~expected acc key body = let ( let* ) = Result.bind in @@ -74,7 +69,7 @@ let insert_section ~expected acc key body = | _ -> Error (Error.multiple_values_in_section key) (** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *) -let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) result = +let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.condition) result = let open Sexplib.Sexp in match sexp with | List (Atom "server" :: sections) -> @@ -91,14 +86,15 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) resul | _ -> Error (Error.invalid_toplevel sexp) (** Read a file from disk and run [parse_server] on it. *) -let load ~expected_keys (path : string) : (t, Condition.t) result = +let load ~expected_keys (path : string) : (t, Condition.condition) result = match Sexplib.Sexp.load_sexp path with | sexp -> parse_server ~expected_keys sexp | exception Sys_error msg -> Error (Error.failed_to_load_file path msg) | exception Failure msg -> Error (Error.syntax_error path msg) (** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *) -let extract_tagged_section (sexp : Sexplib.Sexp.t) : (string * Sexplib.Sexp.t, Condition.t) result = +let extract_tagged_section (sexp : Sexplib.Sexp.t) : + (string * Sexplib.Sexp.t, Condition.condition) result = let open Sexplib.Sexp in match sexp with | List (Atom tag :: body) -> Ok (tag, List body) @@ -106,7 +102,7 @@ let extract_tagged_section (sexp : Sexplib.Sexp.t) : (string * Sexplib.Sexp.t, C (** Look up a section by name, extract its tag, and check the tag is allowed. *) let require_section ~(name : string) ~(valid_tags : string list) (config : t) : - (string * Sexplib.Sexp.t, Condition.t) result = + (string * Sexplib.Sexp.t, Condition.condition) result = let ( let* ) = Result.bind in let* sexp = find_section name config |> Option.to_result ~none:(Error.missing_section name) in let* tag, body = extract_tagged_section sexp in @@ -114,4 +110,3 @@ let require_section ~(name : string) ~(valid_tags : string list) (config : t) : if List.mem tag valid_tags then Ok () else Error (Error.invalid_tag name tag valid_tags) in Ok (tag, body) - *) |
