1 files changed, 216 insertions, 0 deletions
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