package async_js

  1. Overview
  2. Docs

Source file async_js0.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 Core
module Time_ns = Core.Time_ns
module Clock_ns = Async_kernel.Clock_ns
module Scheduler = Async_kernel.Async_kernel_scheduler.Private
open Js_of_ocaml

let sleep d = Clock_ns.after (Time_ns.Span.of_sec d)
let yield () = Scheduler.yield (Scheduler.t ())

let rec extract_js_error (exn : exn) : (string list * Js_error.t) option =
  match exn with
  | Exn.Reraised (msg, exn) ->
    (match extract_js_error exn with
     | Some (messages, js_error) -> Some (msg :: messages, js_error)
     | None -> None)
  | exn ->
    (match Js_error.of_exn exn with
     | Some js_error -> Some ([], js_error)
     | None -> None)
;;

let pretty_print_exception name exn =
  let exn = Async_kernel.Monitor.extract_exn exn in
  let classification =
    match exn with
    | Js_error.Exn err -> `Js err
    | exn ->
      (match extract_js_error exn with
       | None -> `Exn exn
       | Some err -> `Js_and_exn (exn, err))
  in
  match classification with
  | `Js err -> Firebug.console##error_2 (Js.string name) err
  | `Exn exn -> Firebug.console##error_2 (Js.string name) (Js.string (Exn.to_string exn))
  | `Js_and_exn (exn, (messages, err)) ->
    (match messages with
     | [] -> Firebug.console##group (Js.string name)
     | hd :: rest ->
       Firebug.console##group (Js.string hd);
       Firebug.console##log (Js.string name);
       List.iter rest ~f:(fun message -> Firebug.console##error (Js.string message)));
    (* We first output the stringified ocaml exception *)
    Firebug.console##groupCollapsed (Js.string "OCaml Exception");
    Firebug.console##log (Js.string (Exn.to_string exn));
    Firebug.console##groupEnd;
    Firebug.console##error err;
    Firebug.console##groupEnd
;;

let run =
  let module State = struct
    type t =
      | Idle
      | Running
      | Will_run_soon
  end
  in
  let module Next_wakeup = struct
    type t =
      | At of Time_ns.t * float
      | No_wakeup
      | Soon
  end
  in
  let state = ref State.Idle in
  let timeouts = Stack.create () in
  let run_after ~f ~ms = ignore (Dom_html.setTimeout f ms : Dom_html.timeout_id_safe) in
  let rec loop () =
    let t = Scheduler.t () in
    match !state, Scheduler.uncaught_exn t with
    | _, Some _ | State.Running, None -> ()
    | (State.Idle | State.Will_run_soon), None ->
      state := State.Running;
      Scheduler.run_cycle t;
      let next_wakeup : Next_wakeup.t =
        if Scheduler.can_run_a_job t
        then Soon
        else (
          match Scheduler.next_upcoming_event t with
          | None -> No_wakeup
          | Some next ->
            let now = Time_ns.now () in
            let d = Time_ns.diff next now in
            let d_ms = Time_ns.Span.to_ms d in
            if Float.( <= ) d_ms 0. then Soon else At (next, d_ms))
      in
      Option.iter (Scheduler.uncaught_exn_unwrapped t) ~f:(fun (exn, _sexp) ->
        match Async_kernel.Monitor.extract_exn exn with
        | Js_error.Exn err -> Js_error.raise_ err
        | exn ->
          (match Js_error.of_exn exn with
           | None -> raise exn
           | Some err ->
             (* Hack to get a better backtrace *)
             pretty_print_exception "Error:" exn;
             (* And then raise the embedded javascript error that provides a proper
                backtrace with good sourcemap support.
                The name of this javascript error is probably not meaningful which is why
                we first output the serialization of ocaml exception. *)
             Js_error.raise_ err));
      (match next_wakeup with
       | No_wakeup -> state := Idle
       | Soon ->
         state := Will_run_soon;
         run_after ~f:loop ~ms:0.
       | At (at, d_ms) ->
         state := Idle;
         if Stack.is_empty timeouts || Time_ns.( < ) at (Stack.top_exn timeouts)
         then (
           Stack.push timeouts at;
           run_after ~f:run_timeout ~ms:d_ms))
  and run_timeout () =
    (* Each call to [run_timeout] removes exactly one element from [timeouts].  This
       maintains the invariant that [Stack.length timeouts] is exactly the number of
       outstanding timeouts we have registered. *)
    ignore (Stack.pop_exn timeouts : Time_ns.t);
    loop ()
  in
  fun () ->
    match !state with
    | State.Idle ->
      run_after ~f:loop ~ms:0.;
      state := State.Will_run_soon
    | State.Running | State.Will_run_soon -> ()
;;

let initialized_ref = ref false

let initialization =
  lazy
    (let t = Scheduler.t () in
     initialized_ref := true;
     Scheduler.set_job_queued_hook t (fun _ -> run ());
     Scheduler.set_event_added_hook t (fun _ -> run ());
     Scheduler.set_thread_safe_external_job_hook t run;
     Async_kernel.Monitor.Expert.try_with_log_exn
     := pretty_print_exception "Async_kernel: Monitor.try_with";
     Async_kernel.Monitor.detach_and_iter_errors
       Async_kernel.Monitor.main
       ~f:(pretty_print_exception "Async_kernel: Unhandled exception");
     run ())
;;

let init () = force initialization
let initialized () = !initialized_ref

let document_loaded =
  let js_string_compare s =
    let compare_using_javascript_triple_equal_for_strings = phys_equal in
    compare_using_javascript_triple_equal_for_strings (Js.string s)
  in
  let ready_state_change = "readystatechange" in
  let complete = "complete" in
  let readystatechange_ev = Dom.Event.make ready_state_change in
  let add_event target evt handler =
    ignore
      (Dom_html.addEventListener target evt handler Js._false : Dom.event_listener_id)
  in
  fun () ->
    if js_string_compare complete Dom_html.document##.readyState
    then Async_kernel.Deferred.unit
    else (
      let loaded = Async_kernel.Ivar.create () in
      let handler evt =
        if (not (js_string_compare ready_state_change evt##._type))
        || js_string_compare complete Dom_html.document##.readyState
        then Async_kernel.Ivar.fill_if_empty loaded ();
        Js._true
      in
      add_event Dom_html.document Dom_html.Event.domContentLoaded (Dom.handler handler);
      add_event Dom_html.document readystatechange_ev (Dom.handler handler);
      add_event Dom_html.window Dom_html.Event.load (Dom.handler handler);
      Async_kernel.Ivar.read loaded)
;;
OCaml

Innovation. Community. Security.