+1 -1

.ocamlformat

reviewed

··· 1 1 - version=0.19.0 1 1 + version=0.20.1

+4 -4

idl/dune

reviewed

··· 5 5 (libraries rresult)) 6 6 7 7 (library 8 8 - (name js_top_worker_client) 9 9 - (public_name js_top_worker-client) 10 10 - (modules worker_rpc) 11 11 - (libraries js_top_worker_rpc lwt brr)) 8 8 + (name js_top_worker_client) 9 9 + (public_name js_top_worker-client) 10 10 + (modules worker_rpc) 11 11 + (libraries js_top_worker_rpc lwt brr)) 12 12 13 13 (library 14 14 (name js_top_worker_rpc_def)

-64

idl/idl.ml

reviewed

··· 30 30 type t 31 31 32 32 val t : t Rpc.Types.def 33 33 - 34 33 val internal_error_of : exn -> t option 35 34 end 36 35 ··· 67 66 68 67 module type RPC = sig 69 68 type implementation 70 70 - 71 69 type 'a res 72 72 - 73 70 type ('a, 'b) comp 74 74 - 75 71 type _ fn 76 72 77 73 val implement : Interface.description -> implementation 78 78 - 79 74 val ( @-> ) : 'a Param.t -> 'b fn -> ('a -> 'b) fn 80 80 - 81 75 val returning : 'a Param.t -> 'b Error.t -> ('a, 'b) comp fn 82 82 - 83 76 val declare : string -> string list -> 'a fn -> 'a res 84 84 - 85 77 val declare_notification : string -> string list -> 'a fn -> 'a res 86 78 end 87 79 ··· 89 81 type 'a t 90 82 91 83 val return : 'a -> 'a t 92 92 - 93 84 val bind : 'a t -> ('a -> 'b t) -> 'b t 94 94 - 95 85 val fail : exn -> 'a t 96 86 end 97 87 98 88 exception MarshalError of string 99 99 - 100 89 exception UnknownMethod of string 101 101 - 102 90 exception UnboundImplementation of string list 103 103 - 104 91 exception NoDescription 105 92 106 93 let get_wire_name description name = ··· 141 128 module Make (M : MONAD) = struct 142 129 module type RPCTRANSFORMER = sig 143 130 type 'a box 144 144 - 145 131 type ('a, 'b) resultb = ('a, 'b) result box 146 146 - 147 132 type rpcfn = Rpc.call -> Rpc.response M.t 148 133 149 134 val lift : ('a -> 'b M.t) -> 'a -> 'b box 150 150 - 151 135 val bind : 'a box -> ('a -> 'b M.t) -> 'b box 152 152 - 153 136 val return : 'a -> 'a box 154 154 - 155 137 val get : 'a box -> 'a M.t 156 156 - 157 138 val ( !@ ) : 'a box -> 'a M.t 158 158 - 159 139 val put : 'a M.t -> 'a box 160 160 - 161 140 val ( ~@ ) : 'a M.t -> 'a box 162 141 end 163 142 164 143 module T = struct 165 144 type 'a box = { box : 'a M.t } 166 166 - 167 145 type ('a, 'b) resultb = ('a, 'b) result box 168 168 - 169 146 type rpcfn = Rpc.call -> Rpc.response M.t 170 147 171 148 let lift f x = { box = f x } 172 172 - 173 149 let bind { box = x } f = { box = M.bind x f } 174 174 - 175 150 let return x = { box = M.return x } 176 176 - 177 151 let get { box = x } = x 178 178 - 179 152 let ( !@ ) = get 180 180 - 181 153 let put x = { box = x } 182 182 - 183 154 let ( ~@ ) = put 184 155 end 185 156 186 157 type client_implementation = unit 187 187 - 188 158 type server_implementation = (string, T.rpcfn option) Hashtbl.t 189 159 190 160 module ErrM : sig 191 161 val return : 'a -> ('a, 'b) T.resultb 192 192 - 193 162 val return_err : 'b -> ('a, 'b) T.resultb 194 163 195 164 val checked_bind : ··· 205 174 ('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb 206 175 end = struct 207 176 let return x = T.put (M.return (Ok x)) 208 208 - 209 177 let return_err e = T.put (M.return (Error e)) 210 178 211 179 let checked_bind x f f1 = 212 180 T.bind x T.(function Ok x -> !@(f x) | Error x -> !@(f1 x)) 213 181 214 182 let bind x f = checked_bind x f return_err 215 215 - 216 183 let ( >>= ) x f = bind x f 217 184 end 218 185 219 186 module GenClient () = struct 220 187 type implementation = client_implementation 221 221 - 222 188 type 'a res = T.rpcfn -> 'a 223 223 - 224 189 type ('a, 'b) comp = ('a, 'b) T.resultb 225 190 226 191 type _ fn = ··· 228 193 | Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn 229 194 230 195 let description = ref None 231 231 - 232 196 let strict = ref false 233 233 - 234 197 let make_strict () = strict := true 235 198 236 199 let implement x = ··· 238 201 () 239 202 240 203 let returning a err = Returning (a, err) 241 241 - 242 204 let ( @-> ) t f = Function (t, f) 243 205 244 206 let declare_ is_notification name _ ty (rpc : T.rpcfn) = ··· 343 305 344 306 module GenServer () = struct 345 307 type implementation = server_implementation 346 346 - 347 308 type ('a, 'b) comp = ('a, 'b) T.resultb 348 348 - 349 309 type 'a res = 'a -> unit 350 310 351 311 type _ fn = ··· 353 313 | Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn 354 314 355 315 let funcs = Hashtbl.create 20 356 356 - 357 316 let description = ref None 358 317 359 318 let implement x = ··· 361 320 funcs 362 321 363 322 let returning a b = Returning (a, b) 364 364 - 365 323 let ( @-> ) t f = Function (t, f) 366 324 367 325 let rec has_named_args : type a. a fn -> bool = function ··· 423 381 Hashtbl.add funcs wire_name (Some rpcfn) 424 382 425 383 let declare_notification name a ty = declare_ true name a ty 426 426 - 427 384 let declare name a ty = declare_ false name a ty 428 385 end 429 386 end ··· 432 389 type 'a t = V of 'a | E of exn 433 390 434 391 let return x = V x 435 435 - 436 392 let lift f x = match f x with y -> V y | exception e -> E e 437 437 - 438 393 let bind x (f : 'a -> 'b t) : 'b t = match x with V x -> f x | E e -> E e 439 439 - 440 394 let ( >>= ) = bind 441 441 - 442 395 let fail e = E e 443 443 - 444 396 let run = function V x -> x | E e -> raise e 445 397 end 446 398 ··· 448 400 type 'a t = T of 'a 449 401 450 402 let return x = T x 451 451 - 452 403 let lift f x = T (f x) 453 453 - 454 404 let bind (T x) f = f x 455 455 - 456 405 let ( >>= ) = bind 457 457 - 458 406 let fail e = raise e 459 459 - 460 407 let run (T x) = x 461 408 end 462 409 ··· 517 464 518 465 module Exn = struct 519 466 type rpcfn = Rpc.call -> Rpc.response 520 520 - 521 467 type client_implementation = unit 522 522 - 523 468 type server_implementation = (string, rpcfn option) Hashtbl.t 524 469 525 470 module GenClient (R : sig ··· 527 472 end) = 528 473 struct 529 474 type implementation = client_implementation 530 530 - 531 475 type ('a, 'b) comp = 'a 532 532 - 533 476 type 'a res = 'a 534 477 535 478 type _ fn = ··· 543 486 () 544 487 545 488 let returning a err = Returning (a, err) 546 546 - 547 489 let ( @-> ) t f = Function (t, f) 548 490 549 491 let declare_ is_notification name _ ty = ··· 595 537 inner (None, []) ty 596 538 597 539 let declare name a ty = declare_ false name a ty 598 598 - 599 540 let declare_notification name a ty = declare_ true name a ty 600 541 end 601 542 ··· 630 571 631 572 module GenServer () = struct 632 573 type implementation = server_implementation 633 633 - 634 574 type ('a, 'b) comp = 'a 635 635 - 636 575 type 'a res = 'a -> unit 637 576 638 577 type _ fn = ··· 640 579 | Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn 641 580 642 581 let funcs = Hashtbl.create 20 643 643 - 644 582 let description = ref None 645 583 646 584 let implement x = ··· 648 586 funcs 649 587 650 588 let returning a b = Returning (a, b) 651 651 - 652 589 let ( @-> ) t f = Function (t, f) 653 590 654 591 type boxed_error = BoxedError : 'a Error.t -> boxed_error ··· 718 655 Hashtbl.add funcs wire_name (Some rpcfn) 719 656 720 657 let declare name a ty = declare_ true name a ty 721 721 - 722 658 let declare_notification name a ty = declare_ false name a ty 723 659 end 724 660 end

-21

idl/rpc.ml

reviewed

··· 16 16 *) 17 17 18 18 let debug = ref false 19 19 - 20 19 let set_debug x = debug := x 21 21 - 22 20 let get_debug () = !debug 23 21 24 22 type msg = [ `Msg of string ] ··· 74 72 75 73 (* A type definition has a name and description *) 76 74 and 'a def = { name : string; description : string list; ty : 'a typ } 77 77 - 78 75 and boxed_def = BoxedDef : 'a def -> boxed_def 79 76 80 77 and ('a, 's) field = { ··· 89 86 } 90 87 91 88 and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field 92 92 - 93 89 and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result } 94 90 95 91 and 'a structure = { ··· 109 105 } 110 106 111 107 and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag 112 112 - 113 108 and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result } 114 109 115 110 and 'a variant = { ··· 148 143 { name = "string"; ty = Basic String; description = [ "String" ] } 149 144 150 145 let char = { name = "char"; ty = Basic Char; description = [ "Char" ] } 151 151 - 152 146 let unit = { name = "unit"; ty = Unit; description = [ "Unit" ] } 153 147 154 148 let default_types = ··· 165 159 end 166 160 167 161 exception Runtime_error of string * t 168 168 - 169 162 exception Runtime_exception of string * string 170 163 171 164 let map_strings sep fn l = String.concat sep (List.map fn l) ··· 187 180 | Null -> "N" 188 181 189 182 let rpc_of_t x = x 190 190 - 191 183 let rpc_of_int64 i = Int i 192 192 - 193 184 let rpc_of_int32 i = Int (Int64.of_int32 i) 194 194 - 195 185 let rpc_of_int i = Int (Int64.of_int i) 196 196 - 197 186 let rpc_of_bool b = Bool b 198 198 - 199 187 let rpc_of_float f = Float f 200 200 - 201 188 let rpc_of_string s = String s 202 202 - 203 189 let rpc_of_dateTime s = DateTime s 204 204 - 205 190 let rpc_of_base64 s = Base64 s 206 206 - 207 191 let rpc_of_unit () = Null 208 208 - 209 192 let rpc_of_char x = Int (Int64.of_int (Char.code x)) 210 193 211 194 let int64_of_rpc = function ··· 262 245 263 246 module ResultUnmarshallers = struct 264 247 let error_msg m = Error (`Msg m) 265 265 - 266 248 let ok x = Ok x 267 249 268 250 let int64_of_rpc = function ··· 339 321 | _, _ -> rpc 340 322 341 323 type callback = string list -> t -> unit 342 342 - 343 324 type call = { name : string; params : t list; is_notification : bool } 344 325 345 326 let call name params = { name; params; is_notification = false } 346 346 - 347 327 let notification name params = { name; params; is_notification = true } 348 328 349 329 let string_of_call call = ··· 360 340 (* is_notification is to be set as true only if the call was a notification *) 361 341 362 342 let success v = { success = true; contents = v; is_notification = false } 363 363 - 364 343 let failure v = { success = false; contents = v; is_notification = false }

-48

idl/rpc.mli

reviewed

··· 66 66 | Abstract : 'a abstract -> 'a typ 67 67 68 68 and 'a def = { name : string; description : string list; ty : 'a typ } 69 69 - 70 69 and boxed_def = BoxedDef : 'a def -> boxed_def 71 70 72 71 and ('a, 's) field = { ··· 80 79 } 81 80 82 81 and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field 83 83 - 84 82 and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result } 85 83 86 84 and 'a structure = { ··· 101 99 } 102 100 103 101 and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag 104 104 - 105 102 and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result } 106 103 107 104 and 'a variant = { ··· 120 117 } 121 118 122 119 val int : int def 123 123 - 124 120 val int32 : int32 def 125 125 - 126 121 val int64 : int64 def 127 127 - 128 122 val bool : bool def 129 129 - 130 123 val float : float def 131 131 - 132 124 val string : string def 133 133 - 134 125 val char : char def 135 135 - 136 126 val unit : unit def 137 137 - 138 127 val default_types : boxed_def list 139 128 end 140 129 141 130 (** {2 Basic constructors} *) 142 131 143 132 val rpc_of_int64 : int64 -> t 144 144 - 145 133 val rpc_of_int32 : int32 -> t 146 146 - 147 134 val rpc_of_int : int -> t 148 148 - 149 135 val rpc_of_bool : bool -> t 150 150 - 151 136 val rpc_of_float : float -> t 152 152 - 153 137 val rpc_of_string : string -> t 154 154 - 155 138 val rpc_of_dateTime : string -> t 156 156 - 157 139 val rpc_of_base64 : string -> t 158 158 - 159 140 val rpc_of_t : t -> t 160 160 - 161 141 val rpc_of_unit : unit -> t 162 162 - 163 142 val rpc_of_char : char -> t 164 164 - 165 143 val int64_of_rpc : t -> int64 166 166 - 167 144 val int32_of_rpc : t -> int32 168 168 - 169 145 val int_of_rpc : t -> int 170 170 - 171 146 val bool_of_rpc : t -> bool 172 172 - 173 147 val float_of_rpc : t -> float 174 174 - 175 148 val string_of_rpc : t -> string 176 176 - 177 149 val dateTime_of_rpc : t -> string 178 178 - 179 150 val base64_of_rpc : t -> string 180 180 - 181 151 val t_of_rpc : t -> t 182 182 - 183 152 val char_of_rpc : t -> char 184 184 - 185 153 val unit_of_rpc : t -> unit 186 154 187 155 module ResultUnmarshallers : sig 188 156 val int64_of_rpc : t -> (int64, msg) result 189 189 - 190 157 val int32_of_rpc : t -> (int32, msg) result 191 191 - 192 158 val int_of_rpc : t -> (int, msg) result 193 193 - 194 159 val bool_of_rpc : t -> (bool, msg) result 195 195 - 196 160 val float_of_rpc : t -> (float, msg) result 197 197 - 198 161 val string_of_rpc : t -> (string, msg) result 199 199 - 200 162 val dateTime_of_rpc : t -> (string, msg) result 201 201 - 202 163 val base64_of_rpc : t -> (string, msg) result 203 203 - 204 164 val t_of_rpc : t -> (t, msg) result 205 205 - 206 165 val unit_of_rpc : t -> (unit, msg) result 207 207 - 208 166 val char_of_rpc : t -> (char, msg) result 209 167 end 210 168 211 169 (** {2 Calls} *) 212 170 213 171 type callback = string list -> t -> unit 214 214 - 215 172 type call = { name : string; params : t list; is_notification : bool } 216 173 217 174 val call : string -> t list -> call 218 218 - 219 175 val notification : string -> t list -> call 220 220 - 221 176 val string_of_call : call -> string 222 177 223 178 (** {2 Responses} *) ··· 225 180 type response = { success : bool; contents : t; is_notification : bool } 226 181 227 182 val string_of_response : response -> string 228 228 - 229 183 val success : t -> response 230 230 - 231 184 val failure : t -> response 232 185 233 186 (** {2 Run-time errors} *) 234 187 235 188 exception Runtime_error of string * t 236 236 - 237 189 exception Runtime_exception of string * string 238 190 239 191 val set_debug : bool -> unit

-4

idl/rpcmarshal.ml

reviewed

··· 4 4 type err = [ `Msg of string ] 5 5 6 6 let tailrec_map f l = List.rev_map f l |> List.rev 7 7 - 8 7 let ( >>| ) x f = match x with Ok x -> Ok (f x) | Error y -> Error y 9 9 - 10 8 let ( >>= ) x f = match x with Ok x -> f x | Error y -> Error y 11 11 - 12 9 let return x = Ok x 13 13 - 14 10 let ok x = Ok x 15 11 16 12 let rec unmarshal : type a. a typ -> Rpc.t -> (a, err) result =

-5

idl/toplevel_api.ml

reviewed

··· 39 39 type t = err 40 40 41 41 let t = err 42 42 - 43 42 let internal_error_of e = Some (InternalError (Printexc.to_string e)) 44 43 end) 45 44 ··· 59 58 } 60 59 61 60 let implementation = implement description 62 62 - 63 61 let unit_p = Param.mk Types.unit 64 64 - 65 62 let phrase_p = Param.mk Types.string 66 66 - 67 63 let exec_result_p = Param.mk exec_result 68 68 - 69 64 let completion_p = Param.mk completion_result 70 65 71 66 let cmas =

+13 -15

idl/worker_rpc.ml

reviewed

··· 9 9 (** The assumption made in this module is that RPCs are answered in the order 10 10 they are made. *) 11 11 12 12 - type context = 13 13 - { worker : Worker.t 14 14 - ; timeout : int 15 15 - ; timeout_fn : unit -> unit 16 16 - ; waiting : ((Rpc.response, exn) Result.t Lwt_mvar.t * int) Queue.t 17 17 - } 12 12 + type context = { 13 13 + worker : Worker.t; 14 14 + timeout : int; 15 15 + timeout_fn : unit -> unit; 16 16 + waiting : ((Rpc.response, exn) Result.t Lwt_mvar.t * int) Queue.t; 17 17 + } 18 18 19 19 exception Timeout 20 20 21 21 let demux context msg = 22 22 Lwt.async (fun () -> 23 23 match Queue.take_opt context.waiting with 24 24 - | None -> 25 25 - Lwt.return () 24 24 + | None -> Lwt.return () 26 25 | Some (mv, outstanding_execution) -> 27 27 - Brr.G.stop_timer outstanding_execution; 28 28 - let msg : string = Message.Ev.data (Brr.Ev.as_type msg) in 29 29 - Lwt_mvar.put mv (Ok (Marshal.from_string msg 0))) 26 26 + Brr.G.stop_timer outstanding_execution; 27 27 + let msg : string = Message.Ev.data (Brr.Ev.as_type msg) in 28 28 + Lwt_mvar.put mv (Ok (Marshal.from_string msg 0))) 30 29 31 30 let start worker timeout timeout_fn = 32 31 let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in ··· 50 49 Lwt_mvar.take mv >>= fun r -> 51 50 match r with 52 51 | Ok jv -> 53 53 - let response = jv in 54 54 - Lwt.return response 55 55 - | Error exn -> 56 56 - Lwt.fail exn 52 52 + let response = jv in 53 53 + Lwt.return response 54 54 + | Error exn -> Lwt.fail exn

+2 -2

idl/worker_rpc.mli

reviewed

··· 5 5 The assumption made in this module is that RPCs are answered in the order 6 6 they are made. *) 7 7 8 8 - (** Represents the channel used to communicate with the worker *) 9 8 type context 9 9 + (** Represents the channel used to communicate with the worker *) 10 10 11 11 + exception Timeout 11 12 (** When RPC calls take too long, the Lwt promise is set to failed state with 12 13 this exception. *) 13 13 - exception Timeout 14 14 15 15 val start : Brr_webworkers.Worker.t -> int -> (unit -> unit) -> context 16 16 (** [start worker timeout timeout_fn] initialises communications with a web

+1 -1

js_top_worker.opam

reviewed

··· 4 4 authors: "various" 5 5 license: "ISC" 6 6 depends: [ 7 7 - "ocaml" 7 7 + "ocaml" (>= "4.04") 8 8 "js_of_ocaml" {>= "3.11.0"} 9 9 "rresult" 10 10 "astring"

+56 -33

lib/worker.ml

reviewed

··· 31 31 (split_char ~sep:(function '.' -> true | _ -> false) x) 32 32 33 33 let current = split Sys.ocaml_version 34 34 - 35 34 let compint (a : int) b = compare a b 36 35 37 36 let rec compare v v' = ··· 75 74 Longident.(Lident "_print_unit") 76 75 77 76 let stdout_buff = Buffer.create 100 78 78 - 79 77 let stderr_buff = Buffer.create 100 80 78 81 79 (* RPC function implementations *) ··· 83 81 module M = Idl.IdM (* Server is synchronous *) 84 82 85 83 module IdlM = Idl.Make (M) 86 86 - 87 84 module Server = Toplevel_api_gen.Make (IdlM.GenServer ()) 88 85 89 86 (* These are all required to return the appropriate value for the API within the ··· 137 134 (fun b -> Some (Typed_array.String.of_arrayBuffer b)) 138 135 | _ -> None 139 136 140 140 - let load_resource files = 141 141 - let open Js_of_ocaml in 142 142 - fun ~prefix ~path -> 143 143 - Firebug.console##log 144 144 - (Js.string 145 145 - (Printf.sprintf "here we are, loading prefix=%s path=%s" prefix path)); 146 146 - (* let abs_filename = Filename.concat prefix path in *) 147 147 - if List.mem_assoc path files then ( 148 148 - Firebug.console##log (Js.string "path is in files"); 149 149 - let f = sync_get (List.assoc path files) in 150 150 - match f with 151 151 - | Some content -> 152 152 - Firebug.console##log 153 153 - (Js.string 154 154 - (Printf.sprintf "Got result (length=%d)" (String.length content))); 155 155 - (* Sys_js.update_file ~name:abs_filename ~content; *) 156 156 - Some content 157 157 - | None -> None) 158 158 - else ( 159 159 - Firebug.console##log (Js.string "path is NOT in files"); 160 160 - None) 137 137 + type signature = Types.signature_item list 138 138 + type flags = Cmi_format.pers_flags list 139 139 + type header = Misc.modname * signature 140 140 + 141 141 + (** The following two functions are taken from cmi_format.ml in 142 142 + the compiler, but changed to work on bytes rather than input 143 143 + channels *) 144 144 + let input_cmi str = 145 145 + let offset = 0 in 146 146 + let (name, sign) = (Marshal.from_bytes str offset : header) in 147 147 + let offset = offset + Marshal.total_size str offset in 148 148 + let crcs = (Marshal.from_bytes str offset : Misc.crcs) in 149 149 + let offset = offset + Marshal.total_size str offset in 150 150 + let flags = (Marshal.from_bytes str offset : flags) in 151 151 + { 152 152 + Cmi_format.cmi_name = name; 153 153 + cmi_sign = sign; 154 154 + cmi_crcs = crcs; 155 155 + cmi_flags = flags; 156 156 + } 157 157 + 158 158 + let read_cmi filename str = 159 159 + let magic_len = String.length Config.cmi_magic_number in 160 160 + let buffer = Bytes.sub str 0 magic_len in 161 161 + (if buffer <> Bytes.of_string Config.cmi_magic_number then 162 162 + let pre_len = String.length Config.cmi_magic_number - 3 in 163 163 + if 164 164 + Bytes.sub buffer 0 pre_len 165 165 + = Bytes.of_string @@ String.sub Config.cmi_magic_number 0 pre_len 166 166 + then 167 167 + let msg = 168 168 + if buffer < Bytes.of_string Config.cmi_magic_number then "an older" 169 169 + else "a newer" 170 170 + in 171 171 + raise (Cmi_format.Error (Wrong_version_interface (filename, msg))) 172 172 + else raise (Cmi_format.Error (Not_an_interface filename))); 173 173 + input_cmi (Bytes.sub str magic_len (Bytes.length str - magic_len)) 161 174 162 175 let functions : (unit -> unit) list option ref = ref None 163 176 ··· 166 179 try 167 180 Clflags.no_check_prims := true; 168 181 let cmi_files = List.map (fun cmi -> (Filename.basename cmi, cmi)) cmis in 169 169 - Sys_js.mount ~path:"/dynamic/cmis" (load_resource cmi_files); 170 170 - List.iter 171 171 - (fun (path, _) -> Sys_js.register_lazy ("/dynamic/cmis/" ^ path)) 172 172 - cmi_files; 173 173 - Topdirs.dir_directory "/dynamic/cmis"; 182 182 + let old_loader = !Persistent_env.Persistent_signature.load in 183 183 + (Persistent_env.Persistent_signature.load := 184 184 + fun ~unit_name -> 185 185 + let result = 186 186 + Option.bind 187 187 + (List.assoc_opt (String.lowercase_ascii unit_name) cmi_files) 188 188 + sync_get 189 189 + in 190 190 + match result with 191 191 + | Some x -> 192 192 + Some 193 193 + { 194 194 + Persistent_env.Persistent_signature.filename = 195 195 + Sys.executable_name; 196 196 + cmi = read_cmi unit_name (Bytes.of_string x); 197 197 + } 198 198 + | _ -> old_loader ~unit_name); 174 199 Js_of_ocaml.Worker.import_scripts (List.map fst cmas); 175 200 functions := 176 201 Some ··· 188 213 let setup () = 189 214 let open Js_of_ocaml in 190 215 try 191 191 - Sys_js.set_channel_flusher stdout 192 192 - (Buffer.add_string stdout_buff); 193 193 - Sys_js.set_channel_flusher stderr 194 194 - (Buffer.add_string stderr_buff); 216 216 + Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff); 217 217 + Sys_js.set_channel_flusher stderr (Buffer.add_string stderr_buff); 195 218 (match !functions with 196 219 | Some l -> setup l () 197 220 | None -> failwith "Error: toplevel has not been initialised");