(** Bridge between x-ocaml's X_protocol and js_top_worker's message protocol.

    This module translates X_protocol requests into js_top_worker message
    protocol calls and converts the results back into X_protocol responses. *)

module Jtw = Js_top_worker_client_msg
module Msg = Js_top_worker_message.Message

type t = {
  mutable client : Jtw.t;
  url : string;
  mutable init_config : Msg.init_config option;
  mutable on_message_cb : X_protocol.response -> unit;
}

let is_cross_origin url =
  try
    let page_origin = Jv.to_string (Jv.get (Brr.Window.to_jv Brr.G.window) "origin") in
    let url_obj = Jv.new' (Jv.get Jv.global "URL") [| Jv.of_string url |] in
    let url_origin = Jv.to_string (Jv.get url_obj "origin") in
    page_origin <> url_origin
  with _ -> false

let make_effective_url url =
  if is_cross_origin url then begin
    let base_dir =
      match String.rindex_opt url '/' with
      | Some i -> String.sub url 0 i
      | None -> url
    in
    let js_code = Printf.sprintf
      {|globalThis.__global_rel_url="%s";importScripts("%s");|}
      base_dir url in
    let blob = Jv.new' (Jv.get Jv.global "Blob")
      [| Jv.of_jv_array [| Jv.of_string js_code |];
         Jv.obj [| "type", Jv.of_string "application/javascript" |] |] in
    Jv.to_string
      (Jv.call (Jv.get Jv.global "URL") "createObjectURL" [| blob |])
  end else
    url

let make url =
  let effective_url = make_effective_url url in
  let client = Jtw.create effective_url in
  let t = { client; url; init_config = None; on_message_cb = (fun _ -> ()) } in
  (* Wire widget rendering: forward widget messages from the worker to the
     DOM renderer, and send widget events back to the worker. *)
  let send_fn ~widget_id ~handler_id ~event_type ~value =
    Jtw.send_widget_event client ~widget_id ~handler_id ~event_type ~value
  in
  Jtw.set_on_widget_update client (fun widget_id view_any ->
    (* view_any is Js.Unsafe.any — coerce to Jv.t (they are the same repr) *)
    let view_jv : Jv.t = Obj.magic view_any in
    Widget_render.update_widget ~send:send_fn widget_id view_jv);
  Jtw.set_on_widget_clear client (fun widget_id ->
    Widget_render.clear_widget widget_id);
  Jtw.set_on_widget_config client (fun widget_id config ->
    Widget_render.config_widget widget_id config);
  Jtw.set_on_widget_command client (fun widget_id cmd data ->
    Widget_render.command_widget widget_id cmd data);
  Jtw.set_on_widget_register_adapter client (fun kind js_code ->
    Widget_render.register_js_adapter ~send:send_fn kind js_code);
  t

let on_message t fn = t.on_message_cb <- fn

(** Send a response back to x-ocaml via the stored callback. *)
let respond t resp = t.on_message_cb resp

(** Convert Msg.completions to Protocol.completions *)
let convert_completions (c : Msg.completions) : Protocol.completions =
  let convert_kind s : [ `Value | `Constructor | `Variant | `Label
    | `Module | `Modtype | `Type | `MethodCall | `Keyword ] =
    match s with
    | "Constructor" -> `Constructor
    | "Keyword" -> `Keyword
    | "Label" -> `Label
    | "MethodCall" -> `MethodCall
    | "Modtype" -> `Modtype
    | "Module" -> `Module
    | "Type" -> `Type
    | "Variant" -> `Variant
    | _ -> `Value
  in
  {
    Protocol.from = c.from;
    to_ = c.to_;
    entries = List.map (fun (e : Msg.compl_entry) ->
      { Query_protocol.Compl.name = e.name;
        kind = convert_kind e.kind;
        desc = e.desc;
        info = e.info;
        deprecated = e.deprecated;
#if defined OXCAML
        ppx_template_generated = false;
#endif
      }
    ) c.entries;
  }

(** Convert Msg.error to Protocol.error *)
let convert_error (e : Msg.error) : Protocol.error =
  let loc_of_msg_loc (l : Msg.location) : Ocaml_parsing.Location.t =
    { loc_start = { pos_fname = ""; pos_lnum = l.loc_start.pos_lnum;
                    pos_bol = l.loc_start.pos_bol; pos_cnum = l.loc_start.pos_cnum };
      loc_end = { pos_fname = ""; pos_lnum = l.loc_end.pos_lnum;
                  pos_bol = l.loc_end.pos_bol; pos_cnum = l.loc_end.pos_cnum };
      loc_ghost = false }
  in
  let kind = match e.kind with
    | "error" -> Ocaml_parsing.Location.Report_error
    | s when String.length s > 8 && String.sub s 0 8 = "warning:" ->
        Report_warning (String.sub s 8 (String.length s - 8))
    | s when String.length s > 17 && String.sub s 0 17 = "warning_as_error:" ->
        Report_warning_as_error (String.sub s 17 (String.length s - 17))
    | s when String.length s > 6 && String.sub s 0 6 = "alert:" ->
        Report_alert (String.sub s 6 (String.length s - 6))
    | s when String.length s > 15 && String.sub s 0 15 = "alert_as_error:" ->
        Report_alert_as_error (String.sub s 15 (String.length s - 15))
    | _ -> Report_error
  in
  let source = match e.source with
    | "lexer" -> Ocaml_parsing.Location.Lexer
    | "parser" -> Parser
    | "typer" -> Typer
    | "warning" -> Warning
    | "env" -> Env
    | "config" -> Config
    | "unknown" -> Unknown
    | _ -> Unknown
  in
  { Protocol.kind; loc = loc_of_msg_loc e.loc; main = e.main; sub = e.sub; source }

(** Convert Msg.type_info to typed_enclosings entry *)
let convert_type_info (t : Msg.type_info) =
  let loc : Ocaml_parsing.Location.t =
    { loc_start = { pos_fname = ""; pos_lnum = t.loc.loc_start.pos_lnum;
                    pos_bol = t.loc.loc_start.pos_bol; pos_cnum = t.loc.loc_start.pos_cnum };
      loc_end = { pos_fname = ""; pos_lnum = t.loc.loc_end.pos_lnum;
                  pos_bol = t.loc.loc_end.pos_bol; pos_cnum = t.loc.loc_end.pos_cnum };
      loc_ghost = false }
  in
  let tail = match t.tail with
    | "tail_position" -> `Tail_position
    | "tail_call" -> `Tail_call
    | _ -> `No
  in
  (loc, `String t.type_str, tail)

let init ?(findlib_requires = []) ?findlib_index t =
  (* Derive stdlib_dcs from findlib_index base URL so cross-origin universes
     can find their dynamic_cmis.json at the correct absolute URL. *)
  let stdlib_dcs = match findlib_index with
    | Some fi ->
        (match String.rindex_opt fi '/' with
         | Some i -> Some (String.sub fi 0 (i + 1) ^ "lib/ocaml/dynamic_cmis.json")
         | None -> None)
    | None -> None
  in
  let config : Msg.init_config = {
    findlib_requires;
    stdlib_dcs;
    findlib_index;
  } in
  t.init_config <- Some config;
  Lwt.async (fun () ->
    let open Lwt.Infix in
    Jtw.init t.client config >>= fun () ->
    Lwt.return_unit)

let reset t =
  Jtw.terminate t.client;
  let effective_url = make_effective_url t.url in
  t.client <- Jtw.create effective_url;
  match t.init_config with
  | Some config ->
    Lwt.async (fun () ->
      let open Lwt.Infix in
      Jtw.init t.client config >>= fun () ->
      Lwt.return_unit)
  | None -> ()

let post t (req : X_protocol.request) =
  match req with
  | X_protocol.Eval (id, _line_number, code) ->
    (* Tell widget_render which cell is executing so widgets are placed
       right after this cell's <x-ocaml> element in the DOM. *)
    let doc = Brr.Document.to_jv Brr.G.document in
    let cells = Jv.call doc "querySelectorAll" [| Jv.of_string "x-ocaml" |] in
    let cell_el = Jv.call cells "item" [| Jv.of_int id |] in
    if not (Jv.is_null cell_el) then
      Widget_render.set_active_cell cell_el;
    let stream = Jtw.eval_stream t.client code in
    Lwt.async (fun () ->
      Lwt.catch (fun () ->
        Lwt_stream.iter (function
          | Jtw.Phrase { loc; caml_ppf; _ } ->
              let outputs =
                if caml_ppf <> "" then [X_protocol.Meta caml_ppf] else []
              in
              if outputs <> [] then
                respond t (X_protocol.Top_response_at (id, loc, outputs))
          | Jtw.Done { stdout; stderr; caml_ppf; _ } ->
              let outputs = ref [] in
              if caml_ppf <> "" then
                outputs := X_protocol.Meta caml_ppf :: !outputs;
              if stdout <> "" then
                outputs := X_protocol.Stdout stdout :: !outputs;
              if stderr <> "" then
                outputs := X_protocol.Stderr stderr :: !outputs;
              respond t (X_protocol.Top_response (id, List.rev !outputs))
          | Jtw.Error msg ->
              respond t (X_protocol.Top_response
                (id, [X_protocol.Stderr msg]))
        ) stream)
      (fun _exn ->
        respond t (X_protocol.Top_response
          (id, [X_protocol.Stderr "Internal error during evaluation"]));
        Lwt.return_unit))

  | X_protocol.Merlin (id, Protocol.Complete_prefix (src, pos, filename)) ->
    let position = match pos with
      | `Offset n -> n
      | _ -> 0
    in
    Lwt.async (fun () ->
      let open Lwt.Infix in
      Lwt.catch (fun () ->
        Jtw.complete ?filename t.client src position >|= fun completions ->
        respond t (X_protocol.Merlin_response
          (id, Protocol.Completions (convert_completions completions))))
      (fun _exn ->
        respond t (X_protocol.Merlin_response
          (id, Protocol.Completions { Protocol.from = 0; to_ = 0; entries = [] }));
        Lwt.return_unit))

  | X_protocol.Merlin (id, Protocol.Type_enclosing (src, pos, filename)) ->
    let position = match pos with
      | `Offset n -> n
      | _ -> 0
    in
    Lwt.async (fun () ->
      let open Lwt.Infix in
      Lwt.catch (fun () ->
        Jtw.type_at ?filename t.client src position >|= fun types ->
        respond t (X_protocol.Merlin_response
          (id, Protocol.Typed_enclosings (List.map convert_type_info types))))
      (fun _exn ->
        respond t (X_protocol.Merlin_response
          (id, Protocol.Typed_enclosings []));
        Lwt.return_unit))

  | X_protocol.Merlin (id, Protocol.All_errors (src, filename)) ->
    Lwt.async (fun () ->
      let open Lwt.Infix in
      Lwt.catch (fun () ->
        Jtw.errors ?filename t.client src >|= fun errors ->
        respond t (X_protocol.Merlin_response
          (id, Protocol.Errors (List.map convert_error errors))))
      (fun _exn ->
        respond t (X_protocol.Merlin_response (id, Protocol.Errors []));
        Lwt.return_unit))

  | X_protocol.Merlin (id, Protocol.Add_cmis _) ->
    respond t (X_protocol.Merlin_response (id, Protocol.Added_cmis))

  | X_protocol.Format (id, code) ->
    respond t (X_protocol.Formatted_source (id, code))

  | X_protocol.Format_config _ -> ()

  | X_protocol.Setup -> ()

  | X_protocol.Add_cmis _ -> ()  (* js_top_worker manages its own CMIs *)

let eval ~id ~line_number t code =
  post t (X_protocol.Eval (id, line_number, code))

let fmt ~id t code =
  post t (X_protocol.Format (id, code))