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.( >|= )

  type loader_context = {
    checkFile : string -> bool;
    loadFile : string -> S.value;
  }

  type dataSet = S.value * (string * string) list

  class loader (context : loader_context) =
    object (self)
      method path_checker : string S.decoder -> string S.decoder =
        fun check ->
          Decoders.Decoder.bind
            (fun path ->
              if context.checkFile path then Decoders.Decoder.pure path
              else Decoders.Decoder.fail "Expected a path to an existing file")
            check
      (** Check if a file given in the configuration exists: an error is raised
          if the function [checkFile] retun false.

          In the unit tests, the effect is mapped to a function returning alway
          true. *)

      method keep : type a. a S.decoder -> (S.value * a) S.decoder =
        fun decoder value -> S.map (fun v -> (value, v)) decoder value
      (** [keep decoder] transform a decoder and keep the initial value with the
          decoded value.

          This helps to build custom error message, if we want to report an
          error from a different place. *)

      method load_resources : dataSet option S.decoder =
        (* Do not accept dash in the keys, as the caracter is used to alias
           the same file in differents mappings *)
        let no_dash_decoder =
          let* s = S.string in
          match String.exists s ~f:(Char.equal '-') with
          | true -> S.fail "Expected a key without '-'"
          | false -> S.succeed s
        in
        let list_files_decoders =
          self#keep (S.key_value_pairs' no_dash_decoder S.string)
        in
        let get_field = S.field "files" list_files_decoders in

        let* result = S.map context.loadFile (self#path_checker S.string) in
        let files = get_field result in
        let dataSetResult = Result.map (fun v -> Some v) files in
        S.from_result dataSetResult
      (** Load an external file containing the list of files to include.*)

      method parse_expression : type a.
          ?groups:a ImportExpression.T.t list ->
          eq:(a -> a -> bool) ->
          a ExpressionParser.path_builder ->
          a ImportExpression.T.t S.decoder =
        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 look_file :
          dataset:dataSet option -> name:string -> string S.decoder =
        fun ~dataset ~name ->
          self#path_checker
            (S.one_of
               [
                 (* If the file is declared, use it *)
                 ("file", S.field "file" S.string);
                 ( "dataset",
                   (* Otherwise search in the data set *)

                   (* We work inside an option monad : 
                       - Do we have a dataset
                       - Do we have a valid root name to look for
                       - De we have a match in the dataset
                    *)
                   let ( let* ) = Option.bind in
                   let element =
                     let* _, resources = dataset in
                     let* root =
                       match String.split_on_char ~sep:'-' name with
                       | hd :: _ -> Some hd
                       | _ -> None
                     in
                     let* elem = List.assoc_opt root resources in
                     Some elem
                   in
                   match (element, dataset) with
                   | Some value, _ -> S.succeed value
                   | None, Some (t, _) ->
                       let message = "Looking for \"" ^ name ^ "\"" in
                       S.fail_with (Decoders.Error.make ~context:t message)
                   | None, None -> S.fail "No dataset declared" );
               ])

      method source : dataSet option -> Table.t S.decoder =
        fun dataset ->
          (* The file shall either be present in the external, or be declared
           in the dataset *)
          let* name = S.field "name" S.string in
          let* file = self#look_file ~dataset ~name
          and* tab = S.field_opt_or ~default:1 "tab" S.int in
          S.succeed { Table.file; Table.name; Table.tab }

      method external' :
          dataSet option -> string -> ImporterSyntax.Extern.t S.decoder =
        fun dataset 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 = self#look_file ~dataset ~name
          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;
              }
      (** Load the configuration for an external file to link *)

      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* dataset : dataSet option =
          S.field_opt_or ~default:None "dataset" self#load_resources
        in

        let* source = S.field "source" (self#source dataset)
        and* externals =
          S.field_opt_or ~default:[] "externals"
          @@ S.key_value_pairs_seq (self#external' dataset)
        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 context toml =
    S.decode_value (new loader context)#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