aboutsummaryrefslogtreecommitdiff
path: root/lib/configuration/read_conf.ml
blob: d406b0e699ba883ae313bc5d2f67f00d72cafc60 (plain) 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
<
(** The signature for an expression analyzer.

    Every element is mapped to a function, using the tagless final pattern. *)
module type SYM_EXPR = sig
  type 'a repr
  type 'a obs
  type 'a path_repr

  val empty : unit -> 'a repr
  val expr : 'a repr -> 'a repr
  val literal : string -> 'a repr
  val integer : string -> 'a repr
  val path : 'a path_repr -> 'a -> 'a repr
  val concat : 'a repr list ->pre { line-height: 125%; }
td.linenos .normal { color: inherit; background-color: transparent; padding-left: 5px; padding-right: 5px; }
span.linenos { color: inherit; background-color: transparent; padding-left: 5px; padding-right: 5px; }
td.linenos .special { color: #000000; background-color: #ffffc0; padding-left: 5px; padding-right: 5px; }
span.linenos.special { color: #000000; background-color: #ffffc0; padding-left: 5px; padding-right: 5px; }
.highlight .hll { background-color: #ffffcc }
.highlight .c { color: #888888 } /* Comment */
.highlight .err { color: #a61717; background-color: #e3d2d2 } /* Error */
.highlight .k { color: #008800; font-weight: bold } /* Keyword */
.highlight .ch { color: #888888 } /* Comment.Hashbang */
.highlight .cm { color: #888888 } /* Comment.Multiline */
.highlight .cp { color: #cc0000; font-weight: bold } /* Comment.Preproc */
.highlight .cpf { color: #888888 } /* Comment.PreprocFile */
.highlight .c1 { color: #888888 } /* Comment.Single */
.highlight .cs { color: #cc0000; font-weight: bold; background-color: #fff0f0 } /* Comment.Special */
.highlight .gd { color: #000000; background-color: #ffdddd } /* Generic.Deleted */
.highlight .ge { font-style: italic } /* Generic.Emph */
.highlight .gr { color: #aa0000 } /* Generic.Error */
.highlight .gh { color: #333333 } /* Generic.Heading */
.highlight .gi { color: #000000; background-color: #ddffdd } /* Generic.Inserted */
.highlight .go { color: #888888 } /* Generic.Output */
.highlight .gp { color: #555555 } /* Generic.Prompt */
.highlight .gs { font-weight: bold } /* Generic.Strong */
.highlight .gu { color: #666666 } /* Generic.Subheading */
.highlight .gt { color: #aa0000 } /* Generic.Traceback */
.highlight .kc { color: #008800; font-weight: bold } /* Keyword.Constant */
.highlight .kd { color: #008800; font-weight: bold } /* Keyword.Declaration */
.highlight .kn { color: #008800; font-weight: bold } /* Keyword.Namespace */
.highlight .kp { color: #008800 } /* Keyword.Pseudo */
.highlight .kr { color: #008800; font-weight: bold } /* Keyword.Reserved */
.highlight .kt { color: #888888; font-weight: bold } /* Keyword.Type */
.highlight .m { color: #0000DD; font-weight: bold } /* Literal.Number */
.highlight .s { color: #dd2200; background-color: #fff0f0 } /* Literal.String */
.highlight .na { color: #336699 } /* Name.Attribute */
.highlight .nb { color: #003388 } /* Name.Builtin */
.highlight .nc { color: #bb0066; font-weight: bold } /* Name.Class */
.highlight .no { color: #003366; font-weight: bold } /* Name.Constant */
.highlight .nd { color: #555555 } /* Name.Decorator */
.highlight .ne { color: #bb0066; font-weight: bold } /* Name.Exception */
.highlight .nf { color: #0066bb; font-weight: bold } /* Name.Function */
.highlight .nl { color: #336699; font-style: italic } /* Name.Label */
.highlight .nn { color: #bb0066; font-weight: bold } /* Name.Namespace */
.highlight .py { color: #336699; font-weight: bold } /* Name.Property */
.highlight .nt { color: #bb0066; font-weight: bold } /* Name.Tag */
.highlight .nv { color: #336699 } /* Name.Variable */
.highlight .ow { color: #008800 } /* Operator.Word */
.highlight .w { color: #bbbbbb } /* Text.Whitespace */
.highlight .mb { color: #0000DD; font-weight: bold } /* Literal.Number.Bin */
.highlight .mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */
.highlight .mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */
.highlight .mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */
.highlight .mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */
.highlight .sa { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Affix */
.highlight .sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */
.highlight .sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */
.highlight .dl { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Delimiter */
.highlight .sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */
.highlight .s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */
.highlight .se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */
.highlight .sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */
.highlight .si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */
.highlight .sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */
.highlight .sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */
.highlight .s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */
.highlight .ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */
.highlight .bp { color: #003388 } /* Name.Builtin.Pseudo */
.highlight .fm { color: #0066bb; font-weight: bold } /* Name.Function.Magic */
.highlight .vc { color: #336699 } /* Name.Variable.Class */
.highlight .vg { color: #dd7700 } /* Name.Variable.Global */
.highlight .vi { color: #3333bb } /* Name.Variable.Instance */
.highlight .vm { color: #336699 } /* Name.Variable.Magic */
.highlight .il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long */
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-12 14:29:59 +0000
n class="n">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 | ImportErrors.UnknowFunction _ as e -> Error (ImportErrors.repr_error e) | 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 exception Divergent (** Ensure the group criteria in window functions match the global group by criteria. *) exception NestedGroup (** Raised when a group contains another one *) (** Traverse the configuration tree until finding a group window. *) let matchWindowGroup : eq:('a -> 'a -> bool) -> subset:'a ImportExpression.T.t list -> 'a ImportExpression.T.t -> unit = fun ~eq ~subset expression -> let open ImportExpression.T in let rec f isIngroup = function | Empty | Literal _ | Integer _ | Path _ -> () | Expr e -> f isIngroup e | Concat pp | Function' (_, pp) | Function (_, pp) | Nvl pp | Join (_, pp) -> List.iter ~f:(f isIngroup) pp | Window (expr, pp1, pp2) -> let () = if List.equal ~eq:(ImportExpression.T.equal eq) subset pp1 then () else match subset with | [] -> () | _ -> raise_notrace Divergent in let () = match isIngroup with | true -> raise NestedGroup | false -> () in ignore @@ ImportExpression.T.map_window ~f:(f true) expr; List.iter ~f:(f true) pp1; List.iter ~f:(f true) pp2 | BOperator (_, arg1, arg2) -> f isIngroup arg1; f isIngroup arg2 | GEquality (_, arg1, args) -> f isIngroup arg1; List.iter ~f:(f isIngroup) args in f false expression 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. ?groups:a ImportExpression.T.t list -> eq:(a -> a -> bool) -> a ExpressionParser.path_builder -> S.value -> (a ImportExpression.T.t, S.value Decoders.Error.t) result = fun ?(groups = []) ~eq path -> S.string >>= fun v -> match ExpressionParser.of_string path v with | Error e -> S.fail_with Decoders.Error.(make e) | Ok expr -> ( (* Now check that every window function include at least the uniq list *) match matchWindowGroup ~eq ~subset:groups expr with | () -> S.succeed expr | exception Divergent -> S.fail "The group function shall match the same arguments as the \ \"uniq\" parameter" | exception NestedGroup -> S.fail "A group function cannot contains another group function") 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 ~eq:Path.equal ExpressionParser.path) and* extern_key = S.field "extern_key" (self#parse_expression ~eq:Int.equal 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 ImporterSyntax.Extern. { intern_key; extern_key; target = { name; file; tab }; allow_missing; match_rule = None; } method sheet = (* Check the uniq property first, beecause the group functions need to include the same expression (at least) *) let* uniq = S.field_opt_or ~default:[] "uniq" @@ S.list (self#parse_expression ~eq:Path.equal ExpressionParser.path) in let* columns = S.field "columns" @@ S.list (self#parse_expression ~eq:Path.equal ~groups:uniq ExpressionParser.path) and* filters = S.field_opt_or ~default:[] "filters" @@ S.list (self#parse_expression ~eq:Path.equal ~groups:uniq ExpressionParser.path) and* sort = S.field_opt_or ~default:[] "sort" @@ S.list (self#parse_expression ~eq:Path.equal ~groups:uniq ExpressionParser.path) in S.succeed @@ fun version source externals locale -> ImporterSyntax. { version; source; externals; columns; filters; sort; uniq; locale } method conf = let* source = S.field "source" self#source and* externals = S.field_opt_or ~default:[] "externals" (S.key_value_pairs_seq self#external_) and* locale = S.field_opt "locale" S.string in let* sheet = S.field "sheet" self#sheet >|= fun v -> v 1 source externals locale 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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-12 14:29:59 +0000