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
open Js_of_ocaml
open Js
open Mjs
(** navigation ML object *)
type push_obj = {
pu_path : string option;
pu_name : string option;
params : (string * any) list option;
query : (string * string) list option;
}
(** navigation ML argument : string ot object *)
type push_arg = PStr of string | PObj of push_obj
(** navigation iterator argument for 'next' *)
type 'a next =
| NUnit | NFalse | NRoute of push_obj | NError of error t
| NFunction of ('a t -> unit)
(** navigation JS object signature *)
class type push_args = object
method path : js_string t optdef readonly_prop
method name : js_string t opt readonly_prop
method params : any table optdef readonly_prop
method query : js_string t table optdef readonly_prop
end
(** JS to ML *)
let to_push_obj (p : push_args t) = {
pu_path = to_optdef to_string p##.path;
pu_name = to_opt to_string p##.name;
params = to_optdef Table.items p##.params;
query = to_optdef (Table.itemsf to_string) p##.query }
(** ML to JS *)
let of_push_obj p : push_args t = object%js
val path = optdef string p.pu_path
val name = opt string p.pu_name
val params = optdef Table.make p.params
val query = optdef (Table.makef string) p.query
end
(** empty navigation object *)
let empty = {pu_path = None; pu_name = None; params = None; query = None}
(** wrapper for navigation guards that don't have access to this *)
let wrap_hook f =
wrap_callback (fun to_ from next ->
let next_arg = match f (to_push_obj to_) (to_push_obj from) with
| NUnit -> to_any ()
| NFalse -> to_any _false
| NRoute r -> to_any (of_push_obj r)
| NError e -> to_any e
| NFunction f -> to_any @@ wrap_callback f in
next next_arg)
(** wrapper for navigation guards that have access to this *)
let wrap_meth_hook f =
wrap_meth_callback (fun this to_ from next ->
let next_arg = match f this (to_push_obj to_) (to_push_obj from) with
| NUnit -> to_any ()
| NFalse -> to_any _false
| NRoute r -> to_any (of_push_obj r)
| NError e -> to_any e
| NFunction f -> to_any @@ wrap_callback f in
next next_arg)