<commit_before>open Std

(* Poor man's test framework *)
type name = string

type test =
  | Single of name * (unit -> unit)
  | Group of name * test list

let test name f = Single (name, f)

let group name tests = Group (name, tests)

exception Detail of exn * string
let () = Printexc.register_printer (function
    | (Detail (exn, msg)) ->
      Some (Printexc.to_string exn ^ "\nAdditional information:\n" ^ msg)
    | _ -> None
  )

let str_match ~re str =
  Str.string_match (Str.regexp (re ^ "$")) str 0

(* Setting up merlin *)
module M = Mpipeline

let from_source ?(with_config=fun x -> x) ~filename text =
  let config = with_config Mconfig.initial in
  let config = Mconfig.({config with query = {config.query with filename}}) in
  (config, Msource.make Trace.null config text)

let process ?with_config ?for_completion filename text =
  let config, source = from_source ?with_config ~filename text in
  M.make Trace.null ?for_completion config source

(* All tests *)

let assert_errors ?with_config
    filename ?(lexer=0) ?(parser=0) ?(typer=0) ?(config=0) source =
  test filename (fun () ->
      let m = process ?with_config filename source in
      let lexer_errors  = M.reader_lexer_errors m in
      let parser_errors = M.reader_parser_errors m in
      let failures, typer_errors  =
        Mtyper.with_typer (M.typer_result m) @@ fun () ->
        Mconfig.((M.final_config m).merlin.failures),
        M.typer_errors m
      in
      let fmt_msg exn =
        match Location.error_of_exn exn with
        | None -> Printexc.to_string exn
        | Some err -> err.Location.msg
      in
      let expect ~count str errors =
        let count' = List.length errors in
        if count <> count' then failwith (
            "expecting " ^ string_of_int count ^ " " ^ str ^ " but got " ^
            string_of_int count' ^ " errors\n" ^
            String.concat "\n- " ("Errors: " :: List.map_end fmt_msg
                                    (lexer_errors @ parser_errors @ typer_errors)
                                    failures)
          )
      in
      expect ~count:lexer "lexer errors" lexer_errors;
      expect ~count:parser "parser errors" parser_errors;
      expect ~count:typer "typer errors" typer_errors;
      expect ~count:config "configuration failures" failures;
    )

let assertf b fmt =
  if b then
    Printf.ikfprintf ignore () fmt
  else
    Printf.ksprintf failwith fmt

let validate_output ?with_config filename source query pred =
  test filename (fun () ->
      let config, source = from_source ?with_config ~filename source in
      let result =
        Query_commands.dispatch (Trace.start (), config, source) query in
      try pred result
      with exn ->
        let info = `Assoc [
            "query", Query_json.dump query;
            "result", Query_json.json_of_response query result;
          ] in
        raise (Detail (exn, Json.pretty_to_string info))
    )

(* FIXME: this sucks. improve. *)
let validate_failure ?with_config filename source query pred =
  test filename (fun () ->
      let config, source = from_source ?with_config ~filename source in
      let for_info, wrapped =
        match Query_commands.dispatch (Trace.start (), config, source) query with
        | exception e -> ("failure", `String (Printexc.to_string e)), `Error e
        | res -> ("result", Query_json.json_of_response query res), `Ok res
      in
      try pred wrapped
      with exn -><commit_msg>fix test frontend<commit_after>open Std

(* Poor man's test framework *)
type name = string

type test =
  | Single of name * (unit -> unit)
  | Group of name * test list

let test name f = Single (name, f)

let group name tests = Group (name, tests)

exception Detail of exn * string
let () = Printexc.register_printer (function
    | (Detail (exn, msg)) ->
      Some (Printexc.to_string exn ^ "\nAdditional information:\n" ^ msg)
    | _ -> None
  )

let str_match ~re str =
  Str.string_match (Str.regexp (re ^ "$")) str 0

(* Setting up merlin *)
module M = Mpipeline

let process ?(with_config=fun x -> x) ?for_completion filename text =
  let config = with_config Mconfig.initial in
  let config = Mconfig.({config with query = {config.query with filename}}) in
  let source = Msource.make Trace.null config text in
  let pipeline = M.make Trace.null config source in
  match for_completion with
  | None -> pipeline
  | Some pos -> M.for_completion pos pipeline

(* All tests *)

let assert_errors ?with_config
    filename ?(lexer=0) ?(parser=0) ?(typer=0) ?(config=0) source =
  test filename (fun () ->
      let m = process ?with_config filename source in
      let lexer_errors  = M.reader_lexer_errors m in
      let parser_errors = M.reader_parser_errors m in
      let failures, typer_errors  =
        Mtyper.with_typer (M.typer_result m) @@ fun () ->
        Mconfig.((M.final_config m).merlin.failures),
        M.typer_errors m
      in
      let fmt_msg exn =
        match Location.error_of_exn exn with
        | None -> Printexc.to_string exn
        | Some err -> err.Location.msg
      in
      let expect ~count str errors =
        let count' = List.length errors in
        if count <> count' then failwith (
            "expecting " ^ string_of_int count ^ " " ^ str ^ " but got " ^
            string_of_int count' ^ " errors\n" ^
            String.concat "\n- " ("Errors: " :: List.map_end fmt_msg
                                    (lexer_errors @ parser_errors @ typer_errors)
                                    failures)
          )
      in
      expect ~count:lexer "lexer errors" lexer_errors;
      expect ~count:parser "parser errors" parser_errors;
      expect ~count:typer "typer errors" typer_errors;
      expect ~count:config "configuration failures" failures;
    )

let assertf b fmt =
  if b then
    Printf.ikfprintf ignore () fmt
  else
    Printf.ksprintf failwith fmt

let validate_output ?with_config filename source query pred =
  test filename (fun () ->
      let pipeline = process ?with_config filename source in
      let result = Query_commands.dispatch pipeline query in
      try pred result
      with exn ->
        let info = `Assoc [
            "query", Query_json.dump query;
            "result", Query_json.json_of_response query result;
          ] in
        raise (Detail (exn, Json.pretty_to_string info))
    )

(* FIXME: this sucks. improve. *)
let validate_failure ?with_config filename source query pred =
  test filename (fun () ->
      let pipeline = process ?with_config filename source in
      let for_info, wrapped =
        match Query_commands.dispatch pipeline query with
        | exception e -> ("failure", `String (Printexc.to_string e)), `Error e
        | res -> ("result", Query_json.json_of_response query res), `Ok res
      in
      try pred wrapped
      with exn ->
{'fraction_non_alphanumeric': 0.0967741935483871, 'fraction_numerical': 0.001466275659824047, 'mean_word_length': 2.515979381443299, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 35, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6329165', 'n_tokens_mistral': 2057, 'n_tokens_neox': 2041, 'n_words': 673}