Source file binding.ml

open Location
open Model
open Printer_tools
open Options

module T = Michelson

type type_kind =
  | Type
  | Init of string

let rec to_type (tk : type_kind) fmt (t : type_) =
  let pp = Format.fprintf fmt in
  let unsupported _ = pp "Unsupported" in
  let number      _ = pp "BigNumber" in
  let string      _ = pp "string" in
  let bytes       _ = pp "string" in
  let date        _ = pp "Date" in
  let bool        _ = pp "boolean" in
  let any         _ = pp "any" in
  let self = to_type tk fmt in
  let doit a b =
    match tk with
    | Type -> a ()
    | Init f -> b f
  in
  let id_f = (fun f -> Format.fprintf fmt "%s" f ) in
  match get_ntype t with
  | Tasset _                        -> unsupported()
  | Tenum _                         -> doit any    id_f
  | Tstate                          -> doit any    id_f
  | Tbuiltin Bunit                  -> doit any    id_f
  | Tbuiltin Bbool                  -> doit bool   id_f
  | Tbuiltin Bint                   -> doit number id_f
  | Tbuiltin Brational              -> doit number (fun f -> Format.fprintf fmt "%s[Object.keys(%s)[0]].dividedBy(%s[Object.keys(%s)[1]])" f f f f)
  | Tbuiltin Bdate                  -> doit date   (fun f -> Format.fprintf fmt "new Date(%s)" f )
  | Tbuiltin Bduration              -> doit number id_f
  | Tbuiltin Btimestamp             -> doit date   (fun f -> Format.fprintf fmt "new Date(%s)" f )
  | Tbuiltin Bstring                -> doit string id_f
  | Tbuiltin Baddress               -> doit string id_f
  | Tbuiltin Btx_rollup_l2_address  -> doit string id_f
  | Tbuiltin Bcurrency              -> doit number id_f
  | Tbuiltin Bsignature             -> doit string id_f
  | Tbuiltin Bkey                   -> doit string id_f
  | Tbuiltin Bkeyhash               -> doit string id_f
  | Tbuiltin Bbytes                 -> doit bytes  id_f
  | Tbuiltin Bnat                   -> doit number id_f
  | Tbuiltin Bchainid               -> doit string id_f
  | Tbuiltin Bbls12_381_fr          -> doit bytes  id_f
  | Tbuiltin Bbls12_381_g1          -> doit bytes  id_f
  | Tbuiltin Bbls12_381_g2          -> doit bytes  id_f
  | Tbuiltin Bnever                 -> doit any    id_f
  | Tbuiltin Bchest                 -> doit bytes  id_f
  | Tbuiltin Bchest_key             -> doit bytes  id_f
  | Tcontainer _                    -> unsupported()
  | Tlist _ty                       -> doit any    id_f
  | Toption ty                      -> self ty
  | Ttuple _tys                     -> doit any    id_f
  | Tset _ty                        -> doit any    id_f
  | Tmap (_kty, _vty)               -> doit any    id_f
  | Tbig_map (_kty, _vty)           -> unsupported()
  | Titerable_big_map ( _kty, _vty) -> unsupported()
  | Tor (_lty, _rty)                -> doit any    id_f
  | Trecord _id                     -> doit any    id_f
  | Tevent _id                      -> unsupported()
  | Tlambda (_ity, _rty)            -> doit any    id_f
  | Tunit                           -> doit any    id_f
  | Tstorage                        -> unsupported()
  | Toperation                      -> unsupported()
  | Tcontract _                     -> unsupported()
  | Tprog _                         -> unsupported()
  | Tvset _                         -> unsupported()
  | Ttrace _                        -> unsupported()
  | Tticket _                       -> unsupported()
  | Tsapling_state _                -> unsupported()
  | Tsapling_transaction _          -> doit bytes  id_f

let compute_type (model : model) (r : record) =
  let kt = mktype (Tbuiltin Bstring) ~annot:(dumloc "%_kind") in
  let mkt = Gen_michelson.to_type model kt in
  let ty = mktype (Tevent r.name) in
  let mty = Gen_michelson.to_type model ty in
  let mty =
    match r.fields with
    | [] -> T.tunit
    | [ f ] -> {mty with annotation = Some ("%" ^ (unloc_mident f.name))}
    | _ -> mty
  in
  let ty = T.mk_type (T.Tpair [mkt; mty]) in
  let t = Michelson.Utils.type_to_micheline ty in
  t

type input_event = {
  r : record;
  ty : T.obj_micheline;
}

let mk_input_event r ty : input_event =
  { r; ty }

let pp_none _fmt _ = ()

let process (l : language) (model : model) : string =

  let pp_language ppjs ppts =
    match l with
    | Javascript -> ppjs
    | Typescript -> ppts
  in

  let pp_prelude fmt with_number =
    Format.fprintf fmt
      "/* Bindings %s generated by archetype version: %s */

import { registerEvent%a } from '@completium/event-well-crank';%a
" (language_to_string l) version
      (pp_language pp_none pp_str) ", WellEvent, WellEventProcessor, WellEventData"
      (pp_language pp_none pp_str) (if with_number then "\nimport BigNumber from 'bignumber.js';" else "")
  in

  let pp_event fmt (ie : input_event) =
    let pp_interface fmt _ =
      let pp_field fmt (f : record_field) =
        Format.fprintf fmt "%a : %a" pp_mid f.name (to_type Type) f.type_
      in
      Format.fprintf fmt "export interface %a extends WellEvent {@\n  @[%a@]@\n}"
        pp_mid ie.r.name
        (pp_list ",@\n" pp_field) ie.r.fields
    in
    let pp_is_function fmt =
      Format.fprintf fmt "const is_%a = (t%a) => {@\n  return t === '%a'@\n}"
        pp_mid ie.r.name
        (pp_language pp_none pp_str) " : string"
        pp_mid ie.r.name
    in
    let pp_handle_function fmt =
      let pp_field fmt (f : record_field) =
        Format.fprintf fmt "%a : %a" pp_mid f.name (to_type (Init ("event." ^ unloc_mident f.name))) f.type_
      in
      let pp_f fmt (l : record_field list) =
        if List.length l = 1
        then let f = List.nth l 0 in Format.fprintf fmt "%a : %a" pp_mid f.name (to_type (Init ("event"))) f.type_
        else (pp_list ",@\n" pp_field) fmt l
      in
      Format.fprintf fmt "const handle_%a = (handler%a) => (event%a, data%a) => {@\n  handler({@[%a@]}, data)@\n}"
        pp_mid ie.r.name
        (pp_language pp_none pp_str) (" : WellEventProcessor<" ^ (unloc_mident ie.r.name) ^ ">")
        (pp_language pp_none pp_str) " : any"
        (pp_language pp_none pp_str) " ?: WellEventData"
        pp_f ie.r.fields
    in
    let pp_register fmt =
      Format.fprintf fmt "export function register_%a(source%a, handler%a) {
  registerEvent({ source: source, filter: is_%a, process: handle_%a(handler) })
}"
        pp_mid ie.r.name
        (pp_language pp_none pp_str) " : string"
        (pp_language pp_none pp_str) (" : WellEventProcessor<" ^ (unloc_mident ie.r.name) ^ ">")
        pp_mid ie.r.name
        pp_mid ie.r.name
    in
    let pp_newline fmt _ = Format.fprintf fmt "@\n@\n" in

    Format.fprintf fmt "/* Event: %a */" pp_mid ie.r.name;
    pp_newline fmt ();
    (pp_language (pp_none fmt) (pp_interface fmt)) ();
    (pp_language (pp_none fmt) (pp_newline fmt)) ();
    pp_is_function fmt;
    pp_newline fmt ();
    pp_handle_function fmt;
    pp_newline fmt ();
    pp_register fmt
  in

  let events = List.map (fun (r : record) -> mk_input_event r (compute_type model r)) (Model.Utils.get_events model) in
  let with_number = List.exists (fun (ie : input_event) -> List.exists (fun (ef : record_field) -> match get_ntype ef.type_ with | Tbuiltin (Bnat | Bint | Brational) -> true | _ -> false) ie.r.fields) events in
  Format.asprintf "%a@\n%a@."
    pp_prelude with_number
    (pp_list "@\n@\n@\n" pp_event) events