Source file common.ml

open Ppxlib
module SMap = Map.Make(String)

type ('a, 'b) conv0 = {e_to : 'a; e_of : 'b; e_acc : (conv * (string * string)) list}
and conv = (expression, expression) conv0

type ('a, 'b) ctt =
  | CT of 'a
  | TT of 'b

let verbose = match Sys.getenv_opt "PPX_JSOO_DEBUG" with
  | None | Some "0" | Some "false" | Some "no" -> 0
  | Some s ->
    match s with
    | "true" -> Format.printf "ppx_jsoo_debug activated\n@."; 1
    | s -> match int_of_string_opt s with
      | Some i -> Format.printf "ppx_jsoo_debug activated\n@."; i
      | None -> 0

let fake = match Sys.getenv_opt "PPX_JSOO_FAKE" with
  | Some "1" | Some "true" | Some "yes" -> true
  | _ -> false

let debug ?(v=1) ?(force=false) fmt =
  if verbose >= v || force then Format.ksprintf (fun s -> Format.eprintf "%s@." s) fmt
  else Printf.ifprintf () fmt

let jsoo = "jsoo"
let _jsoo = "_jsoo"
let to_jsoo = "to" ^ _jsoo
let of_jsoo = "of" ^ _jsoo
let jsoo_conv = jsoo ^ "_conv"
let _jsoo_conv = _jsoo ^ "_conv"
let _to_jsoo = "_" ^ to_jsoo
let _of_jsoo = "_" ^ of_jsoo
let tuple_jsoo = "_tupjsoo"
let jsoo_mod s = "Ezjs_min." ^ s
let js_mod s = jsoo_mod s

let mkl ~loc txt = { Asttypes.txt; loc }
let mknol txt = mkl ~loc:!Ast_helper.default_loc txt

let lid s = Longident.parse s
let llid ~loc s = mkl ~loc (lid s)

let jsoo_name ?(suff=jsoo) ?(modules=[]) name =
  let rec aux acc = function
    | [] -> assert false
    | [ "t" ] -> acc ^ suff
    | [ s ] -> acc ^ s ^ "_" ^ suff
    | h :: t ->
      match List.assoc_opt h modules with
      | None -> aux (acc ^ h ^ ".") t
      | Some h -> aux (acc ^ h ^ ".") t in
  aux "" (String.split_on_char '.' name)

let jsoo_name_to ?modules name = jsoo_name ?modules ~suff:to_jsoo name
let jsoo_name_of ?modules name = jsoo_name ?modules ~suff:of_jsoo name
let jsoo_name_conv ?modules name = jsoo_name ?modules ~suff:jsoo_conv name

let new_var = let i = ref (-1) in fun () -> incr i; "v" ^ string_of_int !i

let get_string_attr = function
  | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _); _}] ->
    Some s
  | _ -> None

let get_int_attr = function
  | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_integer (s, _)); _}, _); _}] ->
    int_of_string_opt s
  | _ -> None

let get_ident_attr = function
  | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_ident s; _}, _); _}] ->
    Some s
  | _ -> None

let get_enum_attr = function
  | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_construct (lid, _); _}, _); _}] ->
    begin match lid.txt with
      | Lident "String" -> Some `string
      | Lident "Int" -> Some `int
      | _ -> Some `string
    end
  | _ -> Some `string

let get_conv_attr = function
  | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_tuple [e_to; e_of]; _}, _); _}] ->
    Some {e_of = Ppx_js.transform#expression e_of; e_to = Ppx_js.transform#expression e_to; e_acc=[]}
  | PStr [{pstr_desc = Pstr_eval (e, _); _}] ->
    let e = Ppx_js.transform#expression e in
    let loc = e.pexp_loc in
    let e_to, e_of = Ast_builder.Default.(eapply ~loc (evar ~loc "fst") [ e ], eapply ~loc (evar ~loc "snd") [ e ]) in
    Some {e_of; e_to; e_acc=[]}
  | _ -> None

let camel_to_snake s =
  let n = String.length s in
  let b = Bytes.create (2*n) in
  let rec aux i j =
    if i = n then j
    else
      let c = String.get s i in
      let code = Char.code c in
      if code >= 65 && code <= 90 then (
        Bytes.set b j '_';
        Bytes.set b (j+1) (Char.chr (code + 32));
        aux (i+1) (j+2))
      else (
        Bytes.set b j c;
        aux (i+1) (j+1)) in
  let m = aux 0 0 in
  Bytes.(to_string @@ sub b 0 m)

let snake_to_camel s =
  let n = String.length s in
  let b = Bytes.create n in
  let rec aux i j =
    if i = n then j
    else
      let c = String.get s i in
      if c = '_' && i <> (n-1) then (
        let c = String.get s (i+1) in
        Bytes.set b j Char.(chr @@ (code c) - 32);
        aux (i+2) (j+1))
      else (
        Bytes.set b j c;
        aux (i+1) (j+1)) in
  let m = aux 0 0 in
  Bytes.(to_string @@ sub b 0 m)

type field_attributes = {
  fa_meth : bool;
  fa_meth_cb : bool option;
  fa_cb : bool option;
  fa_prop : string option;
  fa_opt : string option;
  fa_key : string;
  fa_ignore : bool;
  fa_array : bool option;
  fa_assoc : bool option;
  fa_number : bool option;
  fa_case : bool;
  fa_inherit : bool;
  fa_enum : [`string | `int] option;
  fa_code : int option;
}

let field_attributes ~key ?(prop="readonly_prop") ?(camel=false) ?(snake=false) l =
  let fa_key =
    if camel then snake_to_camel key
    else if snake then camel_to_snake key
    else key in
  List.fold_left (fun fa a ->
      match a.attr_name.txt with
      (* field only *)
      | "meth" | "jsoo.meth" -> {fa with fa_meth = true; fa_prop = None}
      | "mutable" | "jsoo.mutable" -> {fa with fa_prop = Some "prop"}
      | "readonly" | "jsoo.readonly" -> {fa with fa_prop = Some "readonly_prop"}
      | "writeonly" | "jsoo.writeonly" -> {fa with fa_prop = Some "writeonly_prop"}
      | "key" | "jsoo.key" ->
        let fa_key = match get_string_attr a.attr_payload with
          | None -> key | Some s -> s in
        {fa with fa_key}
      | "case" | "jsoo.case" -> {fa with fa_case = true}
      (* field or core *)
      | "callback" | "jsoo.callback" -> {fa with fa_cb = Some true}
      | "meth_callback" | "jsoo.meth_callback" -> {fa with fa_meth_cb = Some true}
      | "opt" | "jsoo.opt" -> {fa with fa_opt = Some "opt"}
      | "aopt" | "jsoo.aopt" -> {fa with fa_opt = Some "aopt"}
      | "optdef" | "jsoo.optdef" -> {fa with fa_opt = Some "optdef"}
      | "ignore" | "jsoo.ignore" -> {fa with fa_ignore = true}
      | "array" | "jsoo.array" -> {fa with fa_array = Some true}
      | "assoc" | "jsoo.assoc" -> {fa with fa_assoc = Some true}
      | "number" | "jsoo.number" -> {fa with fa_number = Some true}
      | "inherit" | "jsoo.inherit" -> {fa with fa_inherit = true}
      | "enum" | "jsoo.enum" -> {fa with fa_enum = get_enum_attr a.attr_payload}
      | "code" | "jsoo.code" -> {fa with fa_code = get_int_attr a.attr_payload}
      | "camel" | "jsoo.camel" -> {fa with fa_key = snake_to_camel fa.fa_key}
      | "snake" | "jsoo.snake" -> {fa with fa_key = camel_to_snake fa.fa_key}
      | _ -> fa) {
    fa_meth=false; fa_meth_cb=None; fa_cb=None; fa_prop=Some prop;
    fa_opt=None; fa_key; fa_ignore=false; fa_array=None; fa_assoc=None;
    fa_number=None; fa_case=false; fa_inherit=false; fa_enum=None; fa_code=None } l

type core_attributes = {
  ca_opt : string option;
  ca_ignore : bool;
  ca_cb : bool option;
  ca_meth_cb : bool option;
  ca_array : bool option;
  ca_assoc : bool option;
  ca_number : bool option;
  ca_case : bool;
  ca_type : (longident_loc, longident_loc) ctt option;
  ca_conv : conv option;
  ca_enum : [`string | `int] option;
}

let core_attributes
    ?opt ?number ?array_tup ?callback ?meth_callback ?assoc ?typ ?conv ?enum l =
  List.fold_left (fun ca a ->
      match a.attr_name.txt with
      | "opt" | "jsoo.opt" -> {ca with ca_opt = Some "opt"}
      | "optdef" | "jsoo.optdef" -> {ca with ca_opt = Some "optdef"}
      | "aopt" | "jsoo.aopt" -> {ca with ca_opt = Some "aopt"}
      | "ignore" | "jsoo.ignore" -> {ca with ca_ignore = true}
      | "callback" | "jsoo.callback" -> {ca with ca_cb = Some true}
      | "meth_callback" | "jsoo.meth_callback" -> {ca with ca_meth_cb = Some true}
      | "array" | "jsoo.array" -> {ca with ca_array = Some true}
      | "assoc" | "jsoo.assoc" -> {ca with ca_assoc = Some true}
      | "number" | "jsoo.number" -> {ca with ca_number = Some true}
      | "case" | "jsoo.case" -> {ca with ca_case = true}
      | "type" | "jsoo.type" ->
        let ca_type = match get_ident_attr a.attr_payload with
          | None -> None
          | Some t -> Some (TT t) in
        {ca with ca_type}
      | "class_type" | "jsoo.class_type" ->
        let ca_type = match get_ident_attr a.attr_payload with
          | None -> None
          | Some ct -> Some (CT ct) in
        {ca with ca_type}
      | "conv" | "jsoo.conv" -> {ca with ca_conv = get_conv_attr a.attr_payload}
      | "enum" | "jsoo.enum" -> {ca with ca_enum = get_enum_attr a.attr_payload}

      | _ -> ca) {
    ca_opt=opt; ca_ignore=false; ca_cb=callback; ca_meth_cb=meth_callback;
    ca_array=array_tup; ca_assoc=assoc; ca_number=number; ca_case=false;
    ca_type = typ; ca_conv = conv; ca_enum = enum} l

let field_name ?(case=false) name =
  let name =
    if not case &&
       String.contains (String.sub name 0 (String.length name - 1))'_' then
      name ^ "_"
    else name in
  let code = Char.code @@ String.get name 0 in
  if code = 95 || (code >= 97 && code <= 122) then name
  else "_" ^ name

let prop_kind s = match s with
  | Some "writeonly_prop" -> `Writeonly
  | Some "prop" -> `Readwrite
  | Some "case_prop" -> `Case
  | _ -> `Readonly

let get_new_name =
  let tmp_names = ref ([] : (string * int) list) in
  fun ?(suffix="_tmp") name ->
  let base = "_" ^ name ^ suffix in
  match List.assoc_opt name !tmp_names with
  | None ->
    tmp_names := (name, 0) :: !tmp_names; base
  | Some i ->
    tmp_names := (name, i+1) :: (List.remove_assoc name !tmp_names);
    base ^ string_of_int (i+1)

let get_tuple_name name = get_new_name ~suffix:"_tup" name
let get_variant_name name = get_new_name ~suffix:"_var" name
let get_object_name name = get_new_name ~suffix:"_obj" name

let str_of_expr e = Pprintast.string_of_expression e
let str_of_structure e = Pprintast.string_of_structure e

let str_of_pat e =
  Pprintast.pattern Format.str_formatter e;
  Format.flush_str_formatter ()

let str_of_ct e =
  Pprintast.class_type Format.str_formatter e;
  Format.flush_str_formatter ()

let remove_prefix s n = String.sub s n (String.length s - n)

let same_prefix l =
  let common_prefix s1 s2 =
    let n1 = String.length s1 in
    let n2 = String.length s2 in
    let rec aux i =
      if i < n1 && i < n2 && s1.[i] = s2.[i] then aux (i+1)
      else i, String.sub s1 0 i in
    aux 0 in
  let rec aux n pr = function
    | [] -> n, pr
    | h :: t ->
      let n, pr = common_prefix h pr in
      aux n pr t in
  let check n l = List.for_all (fun s -> String.length s > n) l in
  match l with
  | [] | [ _ ] -> 0
  | h :: t ->
    let n = fst (aux (String.length h) h t) in
    if check n l then n else 0

let has_ezjs_min () =
  Sys.command "ocamlfind query -qe -qo -format %v ezjs_min" = 0