(* {{{ COPYING *(

     This file is part of Merlin, an helper for ocaml editors

     Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
                                Thomas Refis  <refis.thomas(_)gmail.com>
                                Simon Castellan  <simon.castellan(_)iuwt.fr>

     Permission is hereby granted, free of charge, to any person obtaining a
     copy of this software and associated documentation files (the "Software"),
     to deal in the Software without restriction, including without limitation the
     rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
     sell copies of the Software, and to permit persons to whom the Software is
     furnished to do so, subject to the following conditions:

     The above copyright notice and this permission notice shall be included in
     all copies or substantial portions of the Software.

     The Software is provided "as is", without warranty of any kind, express or
     implied, including but not limited to the warranties of merchantability,
     fitness for a particular purpose and noninfringement. In no event shall
     the authors or copyright holders be liable for any claim, damages or other
     liability, whether in an action of contract, tort or otherwise, arising
     from, out of or in connection with the software or the use or other dealings
     in the Software.

   )* }}} *)

open Std

let latest_version : Old_protocol.protocol_version = `V3
let current_version = ref `V2

let default_context =
  { Old_protocol.Context.document = None;
    printer_width = None;
    printer_verbosity = None
  }

let invalid_arguments () = failwith "invalid arguments"

open Query_protocol
open Old_protocol

let pos_of_json = function
  | `String "start" -> `Start
  | `String "end" -> `End
  | `Int offset -> `Offset offset
  | `Assoc props -> begin
    try
      match (List.assoc "line" props, List.assoc "col" props) with
      | `Int line, `Int col -> `Logical (line, col)
      | _ -> failwith "Incorrect position"
    with Not_found -> failwith "Incorrect position"
  end
  | _ -> failwith "Incorrect position"

let mandatory_position = function
  | [ `String "at"; jpos ] -> pos_of_json jpos
  | _ -> invalid_arguments ()

let optional_string = function
  | [ `String name ] -> Some name
  | [] -> None
  | _ -> invalid_arguments ()

let string_list l =
  List.map
    ~f:(function
      | `String s -> s
      | _ -> invalid_arguments ())
    l

let source_or_build = function
  | "source" -> `Source
  | "build" -> `Build
  | _ -> invalid_arguments ()

let ml_or_mli = function
  | "ml" -> `ML
  | "mli" -> `MLI
  | _ -> invalid_arguments ()

let auto_ml_or_mli = function
  | "auto" -> `Auto
  | x -> ml_or_mli x

let add_or_remove = function
  | "add" -> `Add
  | "remove" -> `Rem
  | _ -> invalid_arguments ()

let with_failures failures assoc =
  match failures with
  | `Ok -> assoc
  | `Failures failures ->
    let flags, extensions =
      List.fold_left failures ~init:([], []) ~f:(fun (flgs, exts) (str, exn) ->
          match exn with
          | Arg.Bad _ -> (str :: flgs, exts)
          | Extension.Unknown -> (flgs, str :: exts)
          | _ -> assert false)
    in
    let flags =
      match flags with
      | [] -> []
      | failures ->
        let str = String.concat ~sep:", " failures in
        [ `String ("Unknown flags " ^ str) ]
    in
    let extensions =
      match extensions with
      | [] -> []
      | failures ->
        let str = String.concat ~sep:", " failures in
        [ `String ("Unknown extensions " ^ str) ]
    in
    ("failures", `List (flags @ extensions)) :: assoc

let document_of_json =
  let make kind path dot_merlins =
    { Context.dot_merlins;
      kind = auto_ml_or_mli kind;
      path = optional_string path
    }
  in
  function
  | `String "dot_merlin" :: `List dot_merlins :: `String kind :: opt_name ->
    make kind opt_name (Some (string_list dot_merlins))
  | `String kind :: opt_name -> make kind opt_name None
  | _ -> invalid_arguments ()

let request_of_json context =
  let request x = Request (context, x) in
  function
  | `String "type" :: `String "expression" :: `String expr :: opt_pos ->
    request (Query (Type_expr (expr, mandatory_position opt_pos)))
  | [ `String "type";
      `String "enclosing";
      `Assoc [ ("expr", `String expr); ("offset", `Int offset) ];
      jpos
    ] ->
    request
      (Query (Type_enclosing (Some (expr, offset), pos_of_json jpos, None)))
  | [ `String "type"; `String "enclosing"; `String "at"; jpos ] ->
    request (Query (Type_enclosing (None, pos_of_json jpos, None)))
  | [ `String "case"; `String "analysis"; `String "from"; x; `String "to"; y ]
    -> request (Query (Case_analysis (pos_of_json x, pos_of_json y)))
  | [ `String "enclosing"; jpos ] ->
    request (Query (Enclosing (pos_of_json jpos)))
  | [ `String "complete"; `String "prefix"; `String prefix; `String "at"; jpos ]
    ->
    request
      (Query (Complete_prefix (prefix, pos_of_json jpos, [], false, true)))
  | [ `String "complete";
      `String "prefix";
      `String prefix;
      `String "at";
      jpos;
      `String "with";
      `String "doc"
    ] ->
    request (Query (Complete_prefix (prefix, pos_of_json jpos, [], true, true)))
  | [ `String "expand"; `String "prefix"; `String prefix; `String "at"; jpos ]
    -> request (Query (Expand_prefix (prefix, pos_of_json jpos, [], true)))
  | [ `String "search"; `String "polarity"; `String query; `String "at"; jpos ]
    -> request (Query (Polarity_search (query, pos_of_json jpos)))
  | `String "document" :: (`String "" | `Null) :: pos ->
    request (Query (Document (None, mandatory_position pos)))
  | `String "document" :: `String path :: pos ->
    request (Query (Document (Some path, mandatory_position pos)))
  | `String "locate" :: (`String "" | `Null) :: `String choice :: pos ->
    request (Query (Locate (None, ml_or_mli choice, mandatory_position pos)))
  | `String "locate" :: `String path :: `String choice :: pos ->
    request
      (Query (Locate (Some path, ml_or_mli choice, mandatory_position pos)))
  | `String "jump" :: `String target :: pos ->
    request (Query (Jump (target, mandatory_position pos)))
  | [ `String "outline" ] -> request (Query Outline)
  | [ `String "shape"; pos ] -> request (Query (Shape (pos_of_json pos)))
  | [ `String "occurrences"; `String "ident"; `String "at"; jpos ] ->
    request (Query (Occurrences (`Ident_at (pos_of_json jpos), `Buffer)))
  | `String ("reset" | "checkout") :: document ->
    request (Sync (Checkout (document_of_json document)))
  | [ `String "refresh" ] -> request (Sync Refresh)
  | [ `String "errors" ] ->
    request (Query (Errors { lexing = true; parsing = true; typing = true }))
  | `String "dump" :: args -> request (Query (Dump args))
  | [ `String "which"; `String "path"; `String name ] ->
    request (Query (Path_of_source [ name ]))
  | [ `String "which"; `String "path"; `List names ] ->
    request (Query (Path_of_source (string_list names)))
  | [ `String "which"; `String "with_ext"; `String ext ] ->
    request (Query (List_modules [ ext ]))
  | [ `String "which"; `String "with_ext"; `List exts ] ->
    request (Query (List_modules (string_list exts)))
  | [ `String "flags"; `String "set"; `List flags ] ->
    request (Sync (Flags_set (string_list flags)))
  | [ `String "flags"; `String "get" ] -> request (Sync Flags_get)
  | [ `String "find"; `String "use"; `List packages ]
  | `String "find" :: `String "use" :: packages ->
    request (Sync (Findlib_use (string_list packages)))
  | [ `String "find"; `String "list" ] -> request (Query Findlib_list)
  | [ `String "extension"; `String "enable"; `List extensions ] ->
    request (Sync (Extension_set (`Enabled, string_list extensions)))
  | [ `String "extension"; `String "disable"; `List extensions ] ->
    request (Sync (Extension_set (`Disabled, string_list extensions)))
  | [ `String "extension"; `String "list" ] ->
    request (Query (Extension_list `All))
  | [ `String "extension"; `String "list"; `String "enabled" ] ->
    request (Query (Extension_list `Enabled))
  | [ `String "extension"; `String "list"; `String "disabled" ] ->
    request (Query (Extension_list `Disabled))
  | [ `String "path"; `String "list"; `String (("source" | "build") as var) ] ->
    request (Query (Path_list (source_or_build var)))
  | [ `String "path"; `String "reset" ] -> request (Sync Path_reset)
  | `String "path"
    :: `String (("add" | "remove") as action)
    :: `String (("source" | "build") as var)
    :: (`List pathes :: [] | pathes) ->
    request
      (Sync
         (Path (source_or_build var, add_or_remove action, string_list pathes)))
  | [ `String "tell"; pos_start; pos_end; `String content ] ->
    request (Sync (Tell (pos_of_json pos_start, pos_of_json pos_end, content)))
  | [ `String "project"; `String "get" ] -> request (Sync Project_get)
  | [ `String "version" ] -> request (Query Version)
  | [ `String "protocol"; `String "version" ] ->
    request (Sync (Protocol_version None))
  | [ `String "protocol"; `String "version"; `Int n ] ->
    request (Sync (Protocol_version (Some n)))
  | _ -> invalid_arguments ()

let json_of_protocol_version : Old_protocol.protocol_version -> _ = function
  | `V2 -> `Int 2
  | `V3 -> `Int 3

let json_of_sync_command (type a) (command : a sync_command) (response : a) :
    json =
  match (command, response) with
  | Tell _, () -> `Bool true
  | Checkout _, () -> `Bool true
  | Refresh, () -> `Bool true
  | Flags_get, flags -> `List (List.map ~f:Json.string flags)
  | Flags_set _, failures ->
    `Assoc (with_failures failures [ ("result", `Bool true) ])
  | Findlib_use _, failures ->
    `Assoc (with_failures failures [ ("result", `Bool true) ])
  | Extension_set _, failures ->
    `Assoc (with_failures failures [ ("result", `Bool true) ])
  | Path _, () -> `Bool true
  | Path_reset, () -> `Bool true
  | Protocol_version _, (`Selected v, `Latest vm, version) ->
    `Assoc
      [ ("selected", json_of_protocol_version v);
        ("latest", json_of_protocol_version vm);
        ("merlin", `String version)
      ]
  | Project_get, (strs, fails) ->
    let failures =
      match fails with
      | `Failures (_ :: _ as fails) ->
        [ ("failures", `List (List.map ~f:Json.string fails)) ]
      | _ -> []
    in
    `Assoc (("result", `List (List.map ~f:Json.string strs)) :: failures)
  | Idle_job, b -> `Bool b

let classify_response = function
  | Failure s | Exception (Failure s) -> ("failure", `String s)
  | Error error -> ("error", error)
  | Exception exn -> begin
    match Location.error_of_exn exn with
    | Some (`Ok error) -> ("error", Query_json.json_of_error error)
    | None | Some `Already_displayed ->
      ("exception", `String (Printexc.to_string exn))
  end
  | Return (Query cmd, response) ->
    ("return", Query_json.json_of_response cmd response)
  | Return (Sync cmd, response) -> ("return", json_of_sync_command cmd response)

let json_of_response_v2 response =
  let class_, value = classify_response response in
  `List [ `String class_; value ]

let json_of_response_v3 ~notifications response =
  let class_, value = classify_response response in
  `Assoc
    [ ("class", `String class_);
      ("value", value);
      ( "notifications",
        `List
          (List.map
             ~f:(fun { Logger.section; msg } ->
               `Assoc [ ("section", `String section); ("message", `String msg) ])
             notifications) )
    ]

let json_of_response notifications response =
  match !current_version with
  | `V2 -> json_of_response_v2 response
  | `V3 -> json_of_response_v3 ~notifications response

let request_of_json = function
  | `Assoc _ as json ->
    let open Yojson.Basic.Util in
    let document =
      let value = member "document" json in
      let value = if value = `Null then member "context" json else value in
      if value = `Null then None else Some (to_list value |> document_of_json)
    in
    let printer_width = member "printer_width" json |> to_int_option in
    let printer_verbosity =
      member "printer_verbosity" json |> to_string_option
    in
    let context = { Context.document; printer_verbosity; printer_width } in
    let query = member "query" json |> to_list in
    request_of_json context query
  | `List jsons -> request_of_json default_context jsons
  | _ -> invalid_arguments ()

let make_json ?(on_read = ignore) ~input ~output () =
  let rec read buf len =
    on_read input;
    try Unix.read input buf 0 len
    with Unix.Unix_error (Unix.EINTR, _, _) -> read buf len
  in
  let lexbuf = Lexing.from_function read in
  let input =
    Seq.to_dispenser Yojson.Basic.(seq_from_lexbuf (init_lexer ()) lexbuf)
  in
  let output = Unix.out_channel_of_descr output in
  let output' = Yojson.Basic.to_channel output in
  let output json =
    output' json;
    output_char output '\n';
    flush output
  in
  (input, output)

let make_sexp ?on_read ~input ~output () =
  (* Fix for emacs: emacs start-process doesn't distinguish between stdout and
     stderr.  So we redirect stderr to /dev/null with sexp frontend. *)
  begin
    match
      begin
        try Some (Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o600)
        with Unix.Unix_error _ ->
          if Sys.os_type = "Win32" then
            try Some (Unix.openfile "NUL" [ Unix.O_WRONLY ] 0o600)
            with Unix.Unix_error _ -> None
          else None
      end
    with
    | None -> ()
    | Some fd ->
      Unix.dup2 fd Unix.stderr;
      Unix.close fd
  end;
  let input' = Sexp.of_file_descr ?on_read input in
  let input' () = Option.map ~f:Sexp.to_json (input' ()) in
  let buf = Buffer.create 8192 in
  let output json =
    let sexp = Sexp.of_json json in
    Sexp.to_buf sexp buf;
    Buffer.add_char buf '\n';
    let contents = Buffer.to_bytes buf in
    let rec write_contents n l =
      if l > 0 then
        let l' = Unix.write output contents n l in
        if l' > 0 then write_contents (n + l') (l - l')
    in
    write_contents 0 (Bytes.length contents);
    if Buffer.length buf > 100_000 then Buffer.reset buf else Buffer.clear buf
  in
  (input', output)
