path: root/lib/configuration/read_conf.ml

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
    | 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
          Syntax.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 ->
        Syntax.
          { 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