open StdLabels
module Report = Qsp_syntax.Report

type result = Report.t list [@@deriving show]
type filters = { level : Report.level option }

module Args = struct
  let input_files = ref []
  let usage = "qsp_parser input_file"
  let anon_fun filename = input_files := filename :: !input_files
  let level_value = ref None

  let level : string -> unit =
   fun str_level ->
    match Report.level_of_string str_level with
    | Ok level_ -> level_value := Some level_
    | Error e ->
        print_endline e;
        exit 1

  let speclist =
    [ ("--level", Arg.String level, "Message level [debug, warn, error]") ]

  let parse () =
    let () = Arg.parse speclist anon_fun usage in
    let filters = { level = !level_value } in
    (!input_files, filters)
end

(** Filter the results given by the analysis *)
let filter_report : filters -> Report.t list -> Report.t -> Report.t list =
 fun filters reports r ->
  let is_ok =
    match filters.level with
    | None -> true
    | Some level -> Report.level_to_enum level >= Report.level_to_enum r.level
  in

  match is_ok with true -> r :: reports | _ -> reports

(** Read the source file until getting a report (the whole location has been
    read properly), or until the first syntax error. 
    *)
let parse_location :
    (module Qparser.Lexer.Encoding) -> Sedlexing.lexbuf -> filters -> unit =
 fun encoding lexbuf filters ->
  let result =
    Qparser.Analyzer.parse (module Qsp_syntax.Type_of) encoding lexbuf
  in

  let result =
    Result.map
      (fun f -> List.fold_left (f []) ~init:[] ~f:(filter_report filters))
      result
  in
  match result with
  | Ok report -> (
      (* Display the result *)
      match report with
      | [] -> ()
      | _ ->
          let start_position, _ = Sedlexing.lexing_positions lexbuf in
          Format.fprintf Format.std_formatter "Location %s@;@[%a@]@."
            start_position.Lexing.pos_fname pp_result report;
          let () =
            match Sys.os_type with "Win32" -> ignore @@ read_line () | _ -> ()
          in
          ())
  | Error e ->
      let start_position, _ = Sedlexing.lexing_positions lexbuf in
      Format.fprintf Format.std_formatter "Location %s@;@[%a]@."
        start_position.Lexing.pos_fname Report.pp e

let () =
  let file_names, filters = Args.parse () in
  let file_name = List.hd file_names in

  let ic = Stdlib.open_in file_name in

  (*let lexer = Lexing.from_channel ~with_positions:true ic in*)
  let lexer, mod_ =
    match Filename.extension file_name with
    | ".qsrc" ->
        ( Sedlexing.Utf8.from_channel ic,
          (module Sedlexing.Utf8 : Qparser.Lexer.Encoding) )
    | ".txt" ->
        ( Sedlexing.Utf16.from_channel ic (Some Little_endian),
          (module struct
            let lexeme lexbuf = Sedlexing.Utf8.lexeme lexbuf
          end : Qparser.Lexer.Encoding) )
    | _ -> raise (Failure "unknown extension")
  in

  let () =
    try
      while true do
        parse_location mod_ lexer filters
      done
    with Qparser.Lexer.EOF -> ()
  in
  let () =
    match Sys.os_type with "Win32" -> ignore @@ read_line () | _ -> ()
  in
  ()