Source file message.ml

(** Message protocol for worker communication.

    This module defines a simple JSON-based message protocol for communication
    between the client and the OCaml toplevel worker. *)

open Js_of_ocaml

(** {1 Types} *)

type mime_val = {
  mime_type : string;
  data : string;
}

type position = {
  pos_cnum : int;
  pos_lnum : int;
  pos_bol : int;
}

type location = {
  loc_start : position;
  loc_end : position;
}

type compl_entry = {
  name : string;
  kind : string;
  desc : string;
  info : string;
  deprecated : bool;
}

type completions = {
  from : int;
  to_ : int;
  entries : compl_entry list;
}

type error = {
  kind : string;
  loc : location;
  main : string;
  sub : string list;
  source : string;
}

type type_info = {
  loc : location;
  type_str : string;
  tail : string;
}

type init_config = {
  findlib_requires : string list;
  stdlib_dcs : string option;
  findlib_index : string option;
}

(** {1 Client -> Worker messages} *)

type client_msg =
  | Init of init_config
  | Eval of { cell_id : int; env_id : string; code : string }
  | Complete of { cell_id : int; env_id : string; source : string; position : int; filename : string option }
  | TypeAt of { cell_id : int; env_id : string; source : string; position : int; filename : string option }
  | Errors of { cell_id : int; env_id : string; source : string; filename : string option }
  | CreateEnv of { env_id : string }
  | DestroyEnv of { env_id : string }
  | WidgetEvent of { widget_id : string; handler_id : string; event_type : string; value : string option }

(** {1 Worker -> Client messages} *)

type worker_msg =
  | Ready
  | InitError of { message : string }
  | Output of {
      cell_id : int;
      stdout : string;
      stderr : string;
      caml_ppf : string;
      mime_vals : mime_val list;
    }
  | OutputAt of {
      cell_id : int;
      loc : int;  (* pos_cnum - character position after phrase *)
      caml_ppf : string;
      mime_vals : mime_val list;
    }
  | Completions of { cell_id : int; completions : completions }
  | Types of { cell_id : int; types : type_info list }
  | ErrorList of { cell_id : int; errors : error list }
  | EvalError of { cell_id : int; message : string }
  | EnvCreated of { env_id : string }
  | EnvDestroyed of { env_id : string }
  | WidgetUpdate of { widget_id : string; view : Widget_view.node }
  | WidgetClear of { widget_id : string }
  | WidgetConfig of { widget_id : string; config : string }
  | WidgetCommand of { widget_id : string; command : string; data : string }
  | WidgetRegisterAdapter of { kind : string; js_code : string }

(** {1 JSON helpers} *)

(** Use plain JSON.stringify/JSON.parse instead of jsoo's Json.output/Json.unsafe_input.
    The jsoo versions use bytestring revivers that are incompatible across different
    jsoo versions (e.g., 6.0.1+ox vs 6.2.0). Since all values in our message objects
    are already proper JS values (created via Js.string, Js.Unsafe.inject, etc.),
    plain JSON works correctly and is cross-version compatible. *)
let json_global : 'a Js.t = Js.Unsafe.pure_js_expr "JSON"
let plain_stringify obj = json_global##stringify obj
let plain_parse (s : Js.js_string Js.t) = json_global##parse s

let json_of_obj pairs =
  Js.Unsafe.obj (Array.of_list (List.map (fun (k, v) -> (k, Js.Unsafe.inject v)) pairs))

let json_string s = Js.Unsafe.inject (Js.string s)
let json_int n = Js.Unsafe.inject n
let json_bool b = Js.Unsafe.inject (Js.bool b)

let json_array arr =
  Js.Unsafe.inject (Js.array (Array.of_list arr))

let get_string obj key =
  Js.to_string (Js.Unsafe.get obj (Js.string key))

let get_int obj key =
  Js.Unsafe.get obj (Js.string key)

let get_string_opt obj key =
  let v = Js.Unsafe.get obj (Js.string key) in
  (* Handle both null and undefined *)
  if Js.Opt.test v then
    Some (Js.to_string v)
  else
    None

let get_array obj key =
  let v = Js.Unsafe.get obj (Js.string key) in
  (* Use Js.Opt.test to check if the value is not null *)
  if Js.Opt.test v then
    Js.to_array v
  else
    [||]

let get_string_array obj key =
  Array.to_list (Array.map Js.to_string (get_array obj key))

(** {1 View node JSON encoding} *)

let rec json_of_view_attr (a : Widget_view.attr) =
  match a with
  | Property (k, v) ->
      json_of_obj [("t", json_string "prop"); ("k", json_string k); ("v", json_string v)]
  | Style (k, v) ->
      json_of_obj [("t", json_string "style"); ("k", json_string k); ("v", json_string v)]
  | Class c ->
      json_of_obj [("t", json_string "cls"); ("v", json_string c)]
  | Handler (ev, id) ->
      json_of_obj [("t", json_string "handler"); ("ev", json_string ev); ("id", json_string id)]

and json_of_view_node (n : Widget_view.node) =
  match n with
  | Text s ->
      json_of_obj [("t", json_string "txt"); ("v", json_string s)]
  | Element { tag; attrs; children } ->
      json_of_obj [
        ("t", json_string "el");
        ("tag", json_string tag);
        ("a", json_array (List.map (fun a -> Js.Unsafe.inject (json_of_view_attr a)) attrs));
        ("c", json_array (List.map (fun c -> Js.Unsafe.inject (json_of_view_node c)) children));
      ]
  | Managed { kind; config } ->
      json_of_obj [
        ("t", json_string "managed");
        ("kind", json_string kind);
        ("config", json_string config);
      ]

let view_attr_of_json obj : Widget_view.attr =
  let t = get_string obj "t" in
  match t with
  | "prop" -> Property (get_string obj "k", get_string obj "v")
  | "style" -> Style (get_string obj "k", get_string obj "v")
  | "cls" -> Class (get_string obj "v")
  | "handler" -> Handler (get_string obj "ev", get_string obj "id")
  | _ -> failwith ("Unknown attr type: " ^ t)

let rec view_node_of_json obj : Widget_view.node =
  let t = get_string obj "t" in
  match t with
  | "txt" -> Text (get_string obj "v")
  | "el" ->
      let attrs = Array.to_list (Array.map view_attr_of_json (get_array obj "a")) in
      let children = Array.to_list (Array.map view_node_of_json (get_array obj "c")) in
      Element { tag = get_string obj "tag"; attrs; children }
  | "managed" ->
      Managed { kind = get_string obj "kind"; config = get_string obj "config" }
  | _ -> failwith ("Unknown node type: " ^ t)

(** {1 Worker message serialization} *)

let json_of_position p =
  json_of_obj [
    ("pos_cnum", json_int p.pos_cnum);
    ("pos_lnum", json_int p.pos_lnum);
    ("pos_bol", json_int p.pos_bol);
  ]

let json_of_location loc =
  json_of_obj [
    ("loc_start", Js.Unsafe.inject (json_of_position loc.loc_start));
    ("loc_end", Js.Unsafe.inject (json_of_position loc.loc_end));
  ]

let json_of_mime_val mv =
  json_of_obj [
    ("mime_type", json_string mv.mime_type);
    ("data", json_string mv.data);
  ]

let json_of_compl_entry e =
  json_of_obj [
    ("name", json_string e.name);
    ("kind", json_string e.kind);
    ("desc", json_string e.desc);
    ("info", json_string e.info);
    ("deprecated", json_bool e.deprecated);
  ]

let json_of_completions c =
  json_of_obj [
    ("from", json_int c.from);
    ("to", json_int c.to_);
    ("entries", json_array (List.map (fun e -> Js.Unsafe.inject (json_of_compl_entry e)) c.entries));
  ]

let json_of_error e =
  json_of_obj [
    ("kind", json_string e.kind);
    ("loc", Js.Unsafe.inject (json_of_location e.loc));
    ("main", json_string e.main);
    ("sub", json_array (List.map json_string e.sub));
    ("source", json_string e.source);
  ]

let json_of_type_info t =
  json_of_obj [
    ("loc", Js.Unsafe.inject (json_of_location t.loc));
    ("type_str", json_string t.type_str);
    ("tail", json_string t.tail);
  ]

let json_of_worker_msg msg =
  let obj = match msg with
    | Ready ->
        json_of_obj [("type", json_string "ready")]
    | InitError { message } ->
        json_of_obj [
          ("type", json_string "init_error");
          ("message", json_string message);
        ]
    | Output { cell_id; stdout; stderr; caml_ppf; mime_vals } ->
        json_of_obj [
          ("type", json_string "output");
          ("cell_id", json_int cell_id);
          ("stdout", json_string stdout);
          ("stderr", json_string stderr);
          ("caml_ppf", json_string caml_ppf);
          ("mime_vals", json_array (List.map (fun mv -> Js.Unsafe.inject (json_of_mime_val mv)) mime_vals));
        ]
    | OutputAt { cell_id; loc; caml_ppf; mime_vals } ->
        json_of_obj [
          ("type", json_string "output_at");
          ("cell_id", json_int cell_id);
          ("loc", json_int loc);
          ("caml_ppf", json_string caml_ppf);
          ("mime_vals", json_array (List.map (fun mv -> Js.Unsafe.inject (json_of_mime_val mv)) mime_vals));
        ]
    | Completions { cell_id; completions } ->
        json_of_obj [
          ("type", json_string "completions");
          ("cell_id", json_int cell_id);
          ("completions", Js.Unsafe.inject (json_of_completions completions));
        ]
    | Types { cell_id; types } ->
        json_of_obj [
          ("type", json_string "types");
          ("cell_id", json_int cell_id);
          ("types", json_array (List.map (fun t -> Js.Unsafe.inject (json_of_type_info t)) types));
        ]
    | ErrorList { cell_id; errors } ->
        json_of_obj [
          ("type", json_string "errors");
          ("cell_id", json_int cell_id);
          ("errors", json_array (List.map (fun e -> Js.Unsafe.inject (json_of_error e)) errors));
        ]
    | EvalError { cell_id; message } ->
        json_of_obj [
          ("type", json_string "eval_error");
          ("cell_id", json_int cell_id);
          ("message", json_string message);
        ]
    | EnvCreated { env_id } ->
        json_of_obj [
          ("type", json_string "env_created");
          ("env_id", json_string env_id);
        ]
    | EnvDestroyed { env_id } ->
        json_of_obj [
          ("type", json_string "env_destroyed");
          ("env_id", json_string env_id);
        ]
    | WidgetUpdate { widget_id; view } ->
        json_of_obj [
          ("type", json_string "widget_update");
          ("widget_id", json_string widget_id);
          ("view", Js.Unsafe.inject (json_of_view_node view));
        ]
    | WidgetClear { widget_id } ->
        json_of_obj [
          ("type", json_string "widget_clear");
          ("widget_id", json_string widget_id);
        ]
    | WidgetConfig { widget_id; config } ->
        json_of_obj [
          ("type", json_string "widget_config");
          ("widget_id", json_string widget_id);
          ("config", json_string config);
        ]
    | WidgetCommand { widget_id; command; data } ->
        json_of_obj [
          ("type", json_string "widget_command");
          ("widget_id", json_string widget_id);
          ("command", json_string command);
          ("data", json_string data);
        ]
    | WidgetRegisterAdapter { kind; js_code } ->
        json_of_obj [
          ("type", json_string "widget_register_adapter");
          ("kind", json_string kind);
          ("js_code", json_string js_code);
        ]
  in
  Js.to_string (plain_stringify obj)

(** {1 Client message parsing} *)

let parse_init_config obj =
  {
    findlib_requires = get_string_array obj "findlib_requires";
    stdlib_dcs = get_string_opt obj "stdlib_dcs";
    findlib_index = get_string_opt obj "findlib_index";
  }

let client_msg_of_string s =
  let obj = plain_parse (Js.string s) in
  let typ = get_string obj "type" in
  match typ with
  | "init" ->
      Init (parse_init_config obj)
  | "eval" ->
      Eval {
        cell_id = get_int obj "cell_id";
        env_id = get_string obj "env_id";
        code = get_string obj "code";
      }
  | "complete" ->
      Complete {
        cell_id = get_int obj "cell_id";
        env_id = get_string obj "env_id";
        source = get_string obj "source";
        position = get_int obj "position";
        filename = get_string_opt obj "filename";
      }
  | "type_at" ->
      TypeAt {
        cell_id = get_int obj "cell_id";
        env_id = get_string obj "env_id";
        source = get_string obj "source";
        position = get_int obj "position";
        filename = get_string_opt obj "filename";
      }
  | "errors" ->
      Errors {
        cell_id = get_int obj "cell_id";
        env_id = get_string obj "env_id";
        source = get_string obj "source";
        filename = get_string_opt obj "filename";
      }
  | "create_env" ->
      CreateEnv { env_id = get_string obj "env_id" }
  | "destroy_env" ->
      DestroyEnv { env_id = get_string obj "env_id" }
  | "widget_event" ->
      WidgetEvent {
        widget_id = get_string obj "widget_id";
        handler_id = get_string obj "handler_id";
        event_type = get_string obj "event_type";
        value = get_string_opt obj "value";
      }
  | _ ->
      failwith ("Unknown message type: " ^ typ)

let string_of_worker_msg = json_of_worker_msg