-
Notifications
You must be signed in to change notification settings - Fork 9
/
binding.ml
174 lines (160 loc) · 6.85 KB
/
binding.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
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 Btez -> 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
| Toperation -> unsupported()
| Tcontract _ -> 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