From 6b377719c10d5ab3343fd5221f99a4a21008e25a Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Thu, 14 Mar 2024 08:26:58 +0100 Subject: Initial commit --- lib/configuration/read_conf.ml | 216 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 216 insertions(+) create mode 100644 lib/configuration/read_conf.ml (limited to 'lib/configuration/read_conf.ml') diff --git a/lib/configuration/read_conf.ml b/lib/configuration/read_conf.ml new file mode 100644 index 0000000..8d467a5 --- /dev/null +++ b/lib/configuration/read_conf.ml @@ -0,0 +1,216 @@ +open StdLabels +module Table = ImportDataTypes.Table +module Path = ImportDataTypes.Path + +module ExpressionParser : sig + type 'a path_builder + + val path : Path.t path_builder + val column : Path.column path_builder + + val of_string : + 'a path_builder -> string -> ('a ImportExpression.T.t, string) result +end = struct + module MI = Expression_parser.MenhirInterpreter + module E = MenhirLib.ErrorReports + module L = MenhirLib.LexerUtil + + type error = { + message : string; + start_line : int; + start_pos : int; + end_pos : int; + } + + let range_message start_pos end_pos message = + let start_c = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol + and end_c = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol in + { + message; + start_line = start_pos.Lexing.pos_bol; + start_pos = start_c; + end_pos = end_c; + } + + (** Extract the line in error from the whole expression, and print some + characters just under the faulty part *) + let get_line_error : error -> string -> string = + fun error content -> + let sub_text = + try + let end_pos = String.index_from content error.start_line '\n' in + + String.sub content ~pos:error.start_line + ~len:(end_pos - error.start_line) + with + | Not_found -> + (* There is no new line, extract the ending part *) + let len = String.length content - error.start_line in + String.sub content ~pos:error.start_line ~len + in + (* I’m not sure how to produce it, but the error may be over two lines. + This line is here to prevent the underline to overflow. *) + let stop_pos = min error.end_pos (String.length sub_text) in + let error_length = stop_pos - error.start_pos in + String.concat ~sep:"" + [ + sub_text; + "\n"; + String.make error.start_pos ' '; + String.make error_length '^'; + ] + + let get_parse_error default_position env : error = + match MI.stack env with + | (lazy Nil) -> + range_message default_position.Lexing.lex_start_p + default_position.Lexing.lex_curr_p "Invalid syntax\n" + | (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) -> + let message = + try Expression_parser_messages.message (MI.number state) with + | Not_found -> "Invalid syntax (no specific message for this eror)\n" + in + + range_message start_pos end_pos message + + type 'a path_builder = + Lexing.position -> 'a ImportExpression.T.t MI.checkpoint + + let rec _parse lexbuf (checkpoint : 'a ImportExpression.T.t MI.checkpoint) = + match checkpoint with + | MI.InputNeeded _env -> + let token = Expression_lexer.token lexbuf in + let startp = lexbuf.lex_start_p and endp = lexbuf.lex_curr_p in + let checkpoint = MI.offer checkpoint (token, startp, endp) in + _parse lexbuf checkpoint + | MI.Shifting _ | MI.AboutToReduce _ -> + let checkpoint = MI.resume checkpoint in + _parse lexbuf checkpoint + | MI.HandlingError _env -> + let err = get_parse_error lexbuf _env in + Error err + | MI.Accepted v -> Ok v + | MI.Rejected -> + let err = + range_message lexbuf.lex_start_p lexbuf.lex_curr_p + "invalid syntax (parser rejected the input)" + in + Error err + + let of_string : + 'a path_builder -> string -> ('a ImportExpression.T.t, string) result = + fun f str_expression -> + try + let lexbuf = Lexing.from_string str_expression in + let init = f lexbuf.lex_curr_p in + match _parse lexbuf init with + | Ok res -> Ok res + | Error e -> + let message = + String.concat ~sep:"\n" + [ e.message; get_line_error e str_expression ] + in + Error message + with + | Expression_lexer.UnclosedQuote { line; content } -> + let message = + Printf.sprintf "Unclosed quote at line %d : \"%s\"" line content + in + Error message + | e -> + let message = Printexc.to_string e in + Error message + + let path = Expression_parser.Incremental.path_expr + let column = Expression_parser.Incremental.column_expr +end + +module Make (S : Decoders.Decode.S) = struct + let ( let* ) = S.( let* ) + let ( and* ) = S.( and* ) + let ( >>= ) = S.( >>= ) + let ( >|= ) = S.( >|= ) + + class loader = + object (self) + method parse_expression : type a. + a ExpressionParser.path_builder -> + S.value -> + (a ImportExpression.T.t, S.value Decoders.Error.t) result = + fun path -> + S.string >>= fun v -> + match ExpressionParser.of_string path v with + | Ok expr -> S.succeed expr + | Error e -> S.fail_with Decoders.Error.(make e) + + method source = + let* file = S.field "file" S.string + and* name = S.field "name" S.string + and* tab = S.field_opt_or ~default:1 "tab" S.int in + S.succeed { Table.file; name; tab } + + method external_ name = + let* intern_key = + S.field "intern_key" (self#parse_expression ExpressionParser.path) + and* extern_key = + S.field "extern_key" (self#parse_expression ExpressionParser.column) + and* file = S.field "file" S.string + and* tab = S.field_opt_or ~default:1 "tab" S.int + and* allow_missing = + S.field_opt_or ~default:false "allow_missing" S.bool + in + + S.succeed + Syntax. + { + intern_key; + extern_key; + target = { name; file; tab }; + allow_missing; + match_rule = None; + } + + method sheet = + let* columns = + S.field "columns" + @@ S.list (self#parse_expression ExpressionParser.path) + and* filters = + S.field_opt_or ~default:[] "filters" + @@ S.list (self#parse_expression ExpressionParser.path) + and* sort = + S.field_opt_or ~default:[] "sort" + @@ S.list (self#parse_expression ExpressionParser.path) + and* uniq = + S.field_opt_or ~default:[] "uniq" + @@ S.list (self#parse_expression ExpressionParser.path) + in + S.succeed @@ fun version source externals -> + Syntax.{ version; source; externals; columns; filters; sort; uniq } + + method conf = + let* source = S.field "source" self#source + and* externals = + S.field_opt_or ~default:[] "externals" + (S.key_value_pairs_seq self#external_) + in + let* sheet = + S.field "sheet" self#sheet >|= fun v -> v 1 source externals + in + + S.succeed sheet + end + + let read_file file = + S.decode_file (new loader)#conf file + |> Result.map_error (fun v -> + let formatter = Format.str_formatter in + Format.fprintf formatter "%a@." S.pp_error v; + Format.flush_str_formatter ()) + + let read toml = + S.decode_value (new loader)#conf toml + |> Result.map_error (fun v -> + let formatter = Format.str_formatter in + Format.fprintf formatter "%a@." S.pp_error v; + Format.flush_str_formatter ()) +end -- cgit v1.2.3