Source file vue_component.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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
open Mjs
(** ml types *)
type js_type =
| JString of string
| JObject of any
| JNumber of float
| JInt of int
| JBool of bool
| JArray of any list
| JOther of ((js_string t -> any) callback * any)
type prop_object = {
pr_default : js_type;
pr_required : bool option;
pr_validator : (string -> bool) option;
}
type prop_options =
| PrType of js_type
| PrTypeArray of js_type list
| PrObj of prop_object
type props_options = PrsArray of string list | PrsObj of (string * prop_options) list
type 'all component_element =
| CTemplate of string
| CRender of (('all t, any -> any) meth_callback * ('all t, any -> any) meth_callback js_array t)
module Internal = struct
class type prop_object_js = object
method type_ : (js_string t -> any) callback readonly_prop
method default : any optdef readonly_prop
method required : bool t optdef readonly_prop
method validator : (js_string t -> bool t) callback optdef readonly_prop
end
type vnode = any
class type binding = object
method name : js_string t readonly_prop
method value : any optdef readonly_prop
method oldValue : any optdef readonly_prop
method expression : js_string t optdef readonly_prop
method arg : js_string t optdef readonly_prop
method modifiers : bool t table optdef readonly_prop
end
class type model = object
method prop : js_string t optdef readonly_prop
method event : js_string t optdef readonly_prop
end
class type ['data, 'all] component_common = object
method render : ('all t, any -> any) meth_callback optdef readonly_prop
method staticRenderFns : ('all t, any -> any) meth_callback js_array t optdef readonly_prop
method data : ('all t, unit -> 'data t) meth_callback optdef readonly_prop
method computed : ('all t, unit -> any optdef) meth_callback table optdef readonly_prop
method methods : any table optdef readonly_prop
method watch : ('all t, any -> any -> any) meth_callback table optdef readonly_prop
method beforeCreate : ('all t, unit) meth_callback optdef readonly_prop
method created : ('all t, unit) meth_callback optdef readonly_prop
method beforeMount : ('all t, unit) meth_callback optdef readonly_prop
method mounted : ('all t, unit) meth_callback optdef readonly_prop
method beforeUpdate : ('all t, unit) meth_callback optdef readonly_prop
method updated : ('all t, unit) meth_callback optdef readonly_prop
method activated : ('all t, unit) meth_callback optdef readonly_prop
method deactivated : ('all t, unit) meth_callback optdef readonly_prop
method beforeDestroy : ('all t, unit) meth_callback optdef readonly_prop
method destroyed : ('all t, unit) meth_callback optdef readonly_prop
method errorCaptured : (any -> any -> js_string t -> bool t optdef) callback optdef readonly_prop
method directives : (Dom.element t -> binding t -> vnode -> vnode -> unit) callback table table optdef readonly_prop
method filters : (any -> any) callback table optdef readonly_prop
method delimiters : js_string t js_array t optdef readonly_prop
method functional : bool t optdef readonly_prop
method model : model t optdef readonly_prop
method inheritAttrs : bool t optdef readonly_prop
method comments : bool t optdef readonly_prop
end
class type ['data, 'all] component_arg = object
inherit ['data, 'all] component_common
method props : any optdef readonly_prop
method template : js_string t optdef readonly_prop
method components : ('data, 'all) component_arg t table optdef readonly_prop
method mixins : any js_array t optdef readonly_prop
method extends : any optdef readonly_prop
method name : js_string t optdef readonly_prop
method beforeRouteEnter : (Vue_nav.push_args t -> Vue_nav.push_args t -> (any -> unit) -> unit) callback optdef readonly_prop
method beforeRouteUpdate : ('all t, Vue_nav.push_args t -> Vue_nav.push_args t -> (any -> unit) -> unit) meth_callback optdef readonly_prop
method beforeRouteLeave : ('all t, Vue_nav.push_args t -> Vue_nav.push_args t -> (any -> unit) -> unit) meth_callback optdef readonly_prop
end
type 'all vue_instance = 'all t
class type app = object
method component : js_string t -> ('data, 'all) component_arg t optdef -> 'all vue_instance meth
method component_extend : js_string t -> ('data, 'all) component_arg t optdef -> 'all vue_instance constr meth
end
let js_type_cs : js_type -> (js_string t -> Unsafe.any) callback = function
| JString _ -> Unsafe.pure_js_expr "String"
| JObject _ -> Unsafe.pure_js_expr "Object"
| JNumber _ | JInt _ -> Unsafe.pure_js_expr "Number"
| JBool _ -> Unsafe.pure_js_expr "Boolean"
| JArray _ -> Unsafe.pure_js_expr "Array"
| JOther (cons, _) -> cons
let js_prop_obj {pr_default; pr_required; pr_validator} : prop_object_js t =
let default = match pr_default, pr_required with
| _, Some true -> undefined
| JString s, _ -> def @@ to_any (string s)
| JNumber f, _ -> def @@ to_any (number_of_float f)
| JInt i, _ -> def @@ to_any i
| JBool b, _ -> def @@ to_any (bool b)
| JObject o, _ -> def @@ to_any (wrap_callback (fun () -> o))
| JArray a, _ -> def @@ to_any (wrap_callback (fun () -> of_list a))
| JOther (_, a), _ -> def @@ to_any (wrap_callback (fun () -> a))
in
object%js
val type_ = js_type_cs pr_default
val default = default
val required = optdef bool pr_required
val validator = optdef (fun v -> wrap_callback (fun s -> bool (v (to_string s)))) pr_validator
end
let make_prop = function
| PrType s -> to_any @@ js_type_cs s
| PrTypeArray a -> to_any @@ of_listf js_type_cs a
| PrObj o -> to_any @@ js_prop_obj o
let make_props = function
| PrsObj l ->
to_any @@ Table.make @@ List.map (fun (name, pr) -> name, make_prop pr) l
| PrsArray l ->
to_any (of_listf string l)
type ('data, 'all) component_args = {
template : string option;
props : props_options option;
data : ('all t -> 'data t) option ;
render : ('all t, any -> any) meth_callback option;
static_renders : ('all t, any -> any) meth_callback js_array t option;
computed : ('all t -> any optdef) table_cons option;
watch : ('all t -> any -> any -> any) table_cons option;
methods : any table_cons option;
lifecycle : (string * ('all t -> unit)) list;
error_captured : (any -> any -> string -> bool option) option;
directives : (string * (string * (Dom.element t -> binding t -> vnode -> vnode -> unit)) list) list option;
filters : (string * (any -> any)) list option;
components : (top, top) component_arg t table_cons;
mixins : any list option;
extends : any option;
name : string option;
delimiters : (string * string) option;
functional : bool option;
model : (string option * string option) option;
inherit_attrs : bool option;
comments : bool option;
hook_enter : (Vue_nav.push_obj -> Vue_nav.push_obj -> 'all Vue_nav.next) option;
hook_update : ('all t -> Vue_nav.push_obj -> Vue_nav.push_obj -> 'all Vue_nav.next) option;
hook_leave : ('all t -> Vue_nav.push_obj -> Vue_nav.push_obj -> 'all Vue_nav.next) option;
}
let make_arg c : ('data, 'all) component_arg t =
object%js
val template = optdef string c.template
val props = optdef make_props c.props
val data = optdef (fun f -> wrap_meth_callback (fun d () -> f d)) c.data
val render = Optdef.option c.render
val staticRenderFns = Optdef.option c.static_renders
val computed = optdef (to_tablef (fun c -> wrap_meth_callback (fun this () -> c this))) c.computed
val watch = optdef (to_tablef wrap_meth_callback) c.watch
val methods = optdef to_table c.methods
val beforeCreate = optdef wrap_meth_callback @@ List.assoc_opt "beforeCreate" c.lifecycle
val created = optdef wrap_meth_callback @@ List.assoc_opt "created" c.lifecycle
val beforeMount = optdef wrap_meth_callback @@ List.assoc_opt "beforeMount" c.lifecycle
val mounted = optdef wrap_meth_callback @@ List.assoc_opt "mounted" c.lifecycle
val beforeUpdate = optdef wrap_meth_callback @@ List.assoc_opt "beforeUpdate" c.lifecycle
val updated = optdef wrap_meth_callback @@ List.assoc_opt "updated" c.lifecycle
val activated = optdef wrap_meth_callback @@ List.assoc_opt "activated" c.lifecycle
val deactivated = optdef wrap_meth_callback @@ List.assoc_opt "deactivated" c.lifecycle
val beforeDestroy = optdef wrap_meth_callback @@ List.assoc_opt "beforeDestroy" c.lifecycle
val destroyed = optdef wrap_meth_callback @@ List.assoc_opt "destroyed" c.lifecycle
val errorCaptured = optdef (fun f -> wrap_callback (fun x y s -> optdef bool @@ f x y (to_string s))) c.error_captured
val directives = optdef (Table.makef (fun l -> Table.makef wrap_callback l)) c.directives
val filters = optdef (Table.makef wrap_callback) c.filters
val components = to_tablef_def coerce c.components
val mixins = optdef of_list c.mixins
val extends = Optdef.option c.extends
val name = optdef string c.name
val delimiters = optdef (fun (a, b) -> array [| string a; string b |]) c.delimiters
val functional = optdef bool c.functional
val model = optdef (fun (prop, event) -> object%js val prop = optdef string prop val event = optdef string event end) c.model
val inheritAttrs = optdef bool c.inherit_attrs
val comments = optdef bool c.comments
val beforeRouteEnter = optdef Vue_nav.wrap_hook c.hook_enter
val beforeRouteUpdate = optdef Vue_nav.wrap_meth_hook c.hook_update
val beforeRouteLeave = optdef Vue_nav.wrap_meth_hook c.hook_leave
end
let make_arg_js ?template ?render ?static_renders ?props ?data ?computed ?methods ?watch
?(lifecycle = []) ?error_captured ?directives ?filters ?(components= L [])
?mixins ?extends ?name ?delimiters ?functional ?model ?inherit_attrs ?
?enter ?update ?leave () =
make_arg {
template; props; data; render; static_renders; computed; watch; methods; lifecycle;
error_captured; directives; filters; components; mixins; extends; name;
delimiters; functional; model; inherit_attrs; comments;
hook_enter = enter; hook_update = update; hook_leave = leave }
end
type ('data, 'all) component_args = ('data, 'all) Internal.component_args = {
template : string option;
props : props_options option;
data : ('all t -> 'data t) option ;
render : ('all t, any -> any) meth_callback option;
static_renders : ('all t, any -> any) meth_callback js_array t option;
computed : ('all t -> any optdef) table_cons option;
watch : ('all t -> any -> any -> any) table_cons option;
methods : any table_cons option;
lifecycle : (string * ('all t -> unit)) list;
error_captured : (any -> any -> string -> bool option) option;
directives : (string * (string * (Dom.element t -> Internal.binding t -> Internal.vnode -> Internal.vnode -> unit)) list) list option;
filters : (string * (any -> any)) list option;
components : (top, top) Internal.component_arg t table_cons;
mixins : any list option;
extends : any option;
name : string option;
delimiters : (string * string) option;
functional : bool option;
model : (string option * string option) option;
inherit_attrs : bool option;
comments : bool option;
hook_enter : (Vue_nav.push_obj -> Vue_nav.push_obj -> 'all Vue_nav.next) option;
hook_update : ('all t -> Vue_nav.push_obj -> Vue_nav.push_obj -> 'all Vue_nav.next) option;
hook_leave : ('all t -> Vue_nav.push_obj -> Vue_nav.push_obj -> 'all Vue_nav.next) option;
}
let empty = {
template = None; props = None; data = None; render = None; static_renders = None;
computed = None; watch = None; methods = None; lifecycle = []; error_captured = None;
directives = None; filters = None; components = L []; mixins = None; extends = None;
name = None; delimiters = None; functional = None; model = None; inherit_attrs = None;
comments = None; hook_enter = None; hook_update = None; hook_leave = None
}
let prop ?required pr_default = PrObj { pr_default; pr_required = required; pr_validator = None}
type 'a component = 'a Internal.vue_instance
let make ?template ?render ?static_renders ?props ?data ?computed ?methods ?watch
?lifecycle ?error_captured ?directives ?filters ?components
?mixins ?extends ?delimiters ?functional ?model ?inherit_attrs ?
?enter ?update ?leave ?app ?(version= !Version.v) name =
let arg = Internal.make_arg_js ?template ?render ?static_renders ?props ?data
?computed ?methods ?watch ?lifecycle ?error_captured ?directives ?filters
?components ?mixins ?extends ?delimiters ?functional ?model ?inherit_attrs
?comments ?enter ?update ?leave () in
let v : Internal.app t = match app, version with
| None, `v3 ->
failwith "vue3 only accepts components attached to a root"
| None, `v2 -> Unsafe.pure_js_expr "Vue"
| Some v, _ -> Unsafe.coerce v in
match extends, mixins with
| None, None -> v##component (string name) (def arg)
| _ ->
let cs = v##component_extend (string name) (def arg) in
new%js cs
(** functors *)
module type Tables_S = sig
type all
val methods_t : any table
val watch_t : (all t -> any -> any -> any) table
val computed_t : (all t -> any optdef) table
val components_t : (top, top) Internal.component_arg t table
val add_method : string -> (all t -> 'a) -> unit
val add_method0 : string -> (all t -> 'a) -> unit
val add_method1 : string -> (all t -> 'a -> 'b) -> unit
val add_method2 : string -> (all t -> 'a -> 'b -> 'c) -> unit
val add_method3 : string -> (all t -> 'a -> 'b -> 'c -> 'd) -> unit
val add_method4 : string -> (all t -> 'a -> 'b -> 'c -> 'd -> 'e) -> unit
val add_watch : string -> (all t -> 'a -> 'a -> 'b) -> unit
val add_computed : string -> (all t -> 'a optdef) -> unit
val add_2way_computed : string ->
get:(all t -> 'a optdef) -> set:(all t -> 'b -> unit) -> unit
val add_component : string -> ('a, 'b) Internal.component_arg t -> unit
val merge_lists_component :
?computed:(string * (all t -> any optdef)) list ->
?methods:(string * any) list ->
?watch:(string * (all t -> any -> any -> any)) list ->
?components:(string * (top, top) Internal.component_arg t) list ->
unit -> unit
end
module Tables(S : sig type all end) = struct
type all = S.all
let methods_t = Table.create ()
let watch_t = Table.create ()
let computed_t = Table.create ()
let components_t = Table.create ()
let add_method name m =
Table.add methods_t name (to_any (wrap_meth_callback m))
let add_method0 name m = add_method name m
let add_method1 name m = add_method name m
let add_method2 name m = add_method name m
let add_method3 name m = add_method name m
let add_method4 name m = add_method name m
let add_watch name w = Table.add watch_t name (to_any (wrap_meth_callback w))
let add_computed name c =
Table.add computed_t name (fun this -> Optdef.map (c this) to_any)
let add_2way_computed name ~get ~set = Table.add computed_t name @@
coerce @@ Unsafe.obj [|
"get", to_any @@ wrap_meth_callback (fun this () -> get this);
"set", to_any @@ wrap_meth_callback (fun this value -> set this value) |]
let add_component name c = Table.add components_t name @@ coerce c
let merge_lists_component ?(computed=[]) ?(methods=[]) ?(watch=[]) ?(components=[]) () =
Table.add_list methods_t methods;
Table.add_list computed_t computed;
Table.add_list watch_t watch;
Table.add_list components_t components
end
module Make(S : sig
type data
type all
val name : string
val element : all component_element
val props : props_options option
end) = struct
include Tables(struct type all = S.all end)
let component : S.all component ref = ref (Unsafe.obj [||])
let make ?(export=true) ?(data : (all t -> S.data t) option)
?computed ?methods ?watch ?components ?enter ?update ?lifecycle ?mixins ?app ?version () =
merge_lists_component ?computed ?methods ?watch ?components ();
let template, render, static_renders = match S.element with
| CTemplate t -> Some t, None, None
| CRender (r, s) -> None, Some r, Some s in
component := make ?data ?template ?render ?static_renders ?props:S.props
~methods:(T methods_t) ~watch:(T watch_t) ~computed:(T computed_t)
?enter ?update ?lifecycle ?mixins ?app ?version S.name;
if export then Mjs.export S.name !component;
!component
let get () = !component
end